open Msg

module HT = Hashtbl

type protovers = X86Linux2012 | X86Win2012

type sctltype = Local of int| Remote of (string*int)
  
type sctl = 
    {
      ptype : sctltype;
      ic : in_channel;
      oc : out_channel;
      vers : protovers;
    }

type ctlproc = 
    { 
      sctl : sctl;
      id : int64;
      (* other stuff like a register cache ?  *)
    }

type sctlns =
    {
     ns_id : int64;
     ns_sctl : sctl;
   }

type lockind =
    L_var
  | L_param

type cbase = Vundef | Vbool | Vchar | Vshort | Vint | Vlong | Vvlong | Vuchar
| Vushort | Vuint | Vulong | Vuvlong | Vfloat | Vdouble | Vlongdouble
| Vcomplex | Vdoublex | Vlongdoublex | Vptr | Vvoid | Vnallbase

type rkind =
    Rundef
  | Ru08le
  | Ru16le
  | Ru32le
  | Ru64le
  | Rs08le
  | Rs16le
  | Rs32le
  | Rs64le
  | Ru08be
  | Ru16be
  | Ru32be
  | Ru64be
  | Rs08be
  | Rs16be
  | Rs32be
  | Rs64be
  | Rf32
  | Rf64
  | Rf96
  | Rf128
  | Rx64
  | Rx128
  | Rx192
  | Rnrep

type sctlloc = {
    sl_id : string;
    sl_type : tname;
    sl_kind : lockind;
    sl_lexpr : sctllexpr;
  }
      
and tname =
    Tvoid
  | Tbase of cbase
  | Tstruct of string
  | Tunion of string
  | Tenum of string
  | Tptr of tname
  | Tarr of int * tname
  | Tfun of tname * int * param list
  | Ttypedef of string
  | Tbitfield of int * int * tname
  | Tconst of tname
  | Txaccess
  | Tundef of tname

and attr =
    Noattrsyet

and field = {
    f_off : int;
    f_alist : attr list;
    f_name : string;
    f_type : tname;
  }

and sctldecl = {
    sd_type : tdef;
    sd_id : string;
    sd_off : int32;
  }
    
and sctlenum = {
    se_id : string;
    se_off : int64;
    se_type : tdef;
  }
    
and param = {
    (* attrs left out for now *)
    p_name : string;
    p_type : tname;
  }

and tdef = {
    st_tname : tname;
    st_rep : rkind option;
    st_id : string option;
    st_sz : int64 option;
    st_pos : int option;
    st_w : int option;
    st_plist : param list option;
    st_flist : field list option;
    st_elist : sctlenum list option;
    st_link : tname option;
  }

and sctllexpr =
    Lreg of int
  | Lderef of sctllexpr
  | Ladd of sctllexpr * sctllexpr
  | Lsub of sctllexpr * sctllexpr
  | Lulit of int64
  | Lslit of int64

type srcloc = {
    src_addr : int64;
    src_file : string;
    src_line : int32;
    src_col : int32;
  }

exception Unexpected_message of string
exception Protocol_error of string
exception Unexpected_type of string
exception Invalid_location_kind
exception Unexpected_lexpr

let bad_msg msg = 
  raise (Unexpected_message (msg_to_string msg))

let bad_prot str = 
  raise (Protocol_error str)

let notype: tdef = {
  st_tname = Tvoid;
  st_rep = None;
  st_id = None;
  st_sz = None;
  st_pos = None;
  st_w = None;
  st_plist = None;
  st_flist = None;
  st_elist = None;
  st_link = None;
}

type launch_flag = 
  | Fstdin 
  | Fstdout
  | Fstderr

let launch_flags_to_int64 (flags:launch_flag list) : int64 = 
  List.fold_left (fun x y -> 
		    match y with 
		      | Fstdin -> 
			  Int64.logor x 1L
		      | Fstdout -> 
			  Int64.logor x 2L
		      | Fstderr -> 
			  Int64.logor x 4L) 0L flags

type ctx = 
    {
      r15 : int64;
      r14 : int64;
      r13 : int64;
      r12 : int64;
      rbp : int64;
      rbx : int64;
      r11 : int64;
      r10 : int64;
      r9  : int64;
      r8  : int64;
      rax : int64;
      rcx : int64;
      rdx : int64;
      rsi : int64;
      rdi : int64;
      orig_rax : int64;
      rip : int64;
      cs  : int64;
      eflags : int64;
      rsp : int64;
      ss : int64;
      fs_base : int64;
      gs_base : int64;
      ds : int64;
      es : int64;
      fs : int64;
      gs : int64;
      cursig : int64;
    }
let ctxsize = 224

let empty_ctx = {
      r15 = 0L;
      r14 = 0L;
      r13 = 0L;
      r12 = 0L;
      rbp = 0L;
      rbx = 0L;
      r11 = 0L;
      r10 = 0L;
      r9  = 0L;
      r8  = 0L;
      rax = 0L;
      rcx = 0L;
      rdx = 0L;
      rsi = 0L;
      rdi = 0L;
      orig_rax = 0L;
      rip = 0L;
      cs  = 0L;
      eflags = 0L;
      rsp = 0L;
      ss = 0L;
      fs_base = 0L;
      gs_base = 0L;
      ds = 0L;
      es = 0L;
      fs = 0L;
      gs = 0L;
      cursig = 0L;
    }
  
let parse_ctx (bytes:string) (off:int) : ctx = 
  let r15 = parse_u64 bytes (off + 0) in 
  let r14 = parse_u64 bytes (off + 8) in 
  let r13 = parse_u64 bytes (off + 16) in 
  let r12 = parse_u64 bytes (off + 24) in 
  let rbp = parse_u64 bytes (off + 32) in 
  let rbx = parse_u64 bytes (off + 40) in 
  let r11 = parse_u64 bytes (off + 48) in 
  let r10 = parse_u64 bytes (off + 56) in 
  let r9  = parse_u64 bytes (off + 64) in 
  let r8  = parse_u64 bytes (off + 72) in 
  let rax = parse_u64 bytes (off + 80) in 
  let rcx = parse_u64 bytes (off + 88) in 
  let rdx = parse_u64 bytes (off + 96) in 
  let rsi = parse_u64 bytes (off + 104) in 
  let rdi = parse_u64 bytes (off + 112) in 
  let orig_rax = parse_u64 bytes (off + 120 ) in 
  let rip = parse_u64 bytes (off + 128) in 
  let cs  = parse_u64 bytes (off + 136) in 
  let eflags = parse_u64 bytes (off + 144) in 
  let rsp = parse_u64 bytes (off + 152) in 
  let ss = parse_u64 bytes (off + 160) in 
  let fs_base = parse_u64 bytes (off + 168) in 
  let gs_base = parse_u64 bytes (off + 176) in 
  let ds = parse_u64 bytes (off + 184) in 
  let es = parse_u64 bytes (off + 192) in 
  let fs = parse_u64 bytes (off + 200) in 
  let gs = parse_u64 bytes (off + 208) in 
    { 
      r15 = r15;
      r14 = r14;
      r13 = r13;
      r12 = r12;
      rbp = rbp;
      rbx = rbx;
      r11 = r11;
      r10 = r10;
      r9  = r9;
      r8  = r8;
      rax = rax;
      rcx = rcx;
      rdx = rdx;
      rsi = rsi;
      rdi = rdi;
      orig_rax = orig_rax;
      rip = rip;
      cs  = cs;
      eflags = eflags;
      rsp = rsp;
      ss = ss;
      fs_base = fs_base;
      gs_base = gs_base;
      ds = ds;
      es = es;
      fs = fs;
      gs = gs;
      cursig = 0L;
    }

let format_ctx ctx : string = 
  let buf = Buffer.create ctxsize in 
    append_u64 ctx.r15 buf;
    append_u64 ctx.r14 buf;
    append_u64 ctx.r13 buf;
    append_u64 ctx.r12 buf;
    append_u64 ctx.rbp buf;
    append_u64 ctx.rbx buf;
    append_u64 ctx.r11 buf;
    append_u64 ctx.r10 buf;
    append_u64 ctx.r9  buf;
    append_u64 ctx.r8  buf;
    append_u64 ctx.rax buf;
    append_u64 ctx.rcx buf;
    append_u64 ctx.rdx buf;
    append_u64 ctx.rsi buf;
    append_u64 ctx.rdi buf;
    append_u64 ctx.orig_rax buf;
    append_u64 ctx.rip buf;
    append_u64 ctx.cs  buf;
    append_u64 ctx.eflags buf;
    append_u64 ctx.rsp buf;
    append_u64 ctx.ss buf;
    append_u64 ctx.fs_base buf;
    append_u64 ctx.gs_base buf;
    append_u64 ctx.ds buf;
    append_u64 ctx.es buf;
    append_u64 ctx.fs buf;
    append_u64 ctx.gs buf;
    append_u64 ctx.cursig buf;
    Buffer.contents buf

type loctab = (int64, (int64 * sctlloc list)) HT.t

type typetab = (string, tdef) HT.t

type trace_flag = 
  | TFsyscall 
  | TFexec 
  | TFfork
  | TFclone
  | TFsignal
  | TFexit
  | TFtrap
  | TFsnap
  | TFstepctx
  | TFload
  | TFunload

let trace_flags_to_int64 (flags:trace_flag list) : int64 = 
  List.fold_left (fun x y -> 
		    match y with 
		      | TFsyscall -> 
			  Int64.logor x 2L
		      | TFexec -> 
			  Int64.logor x 4L
		      | TFfork -> 
			  Int64.logor x 8L
		      | TFclone -> 
			  Int64.logor x 16L
		      | TFsignal -> 
			  Int64.logor x 32L
		      | TFexit -> 
			  Int64.logor x 64L
		      | TFtrap -> 
			  Int64.logor x 128L
		      | TFsnap -> 
			  Int64.logor x 256L
		      | TFstepctx -> 
			  Int64.logor x 512L
		      | TFload -> 
			  Int64.logor x 1024L
		      | TFunload -> 
			  Int64.logor x 2048L

		 ) 0L flags


type event_details = 
  | Esyscall of ctx
  | Eexec of ctx
  | Efork of (int64*ctx*ctx)
  | Eclone of (int64*ctx*ctx)
  | Esignal of ctx
  | Eexit
  | Etrap of (int64*ctx)
  | Esnap of (int64*int64*ctx)
  | Eload of (string*int64*ctx)
  | Eunload of (string*int64*ctx)

let ev2str (ev:event_details) : string =
  match ev with
    Esyscall (_) -> "Esyscal"
  | Eexec (_) -> "Eexec"
  | Efork (_) -> "Efork"
  | Eclone (_) -> "Eclone"
  | Esignal (_) -> "Esignal"
  | Eexit -> "Eexit"
  | Etrap (_) -> "Etrap"
  | Esnap (_) -> "Esnap"
  | Eload (path,base,ctx) -> String.concat " " ["Eload"; path]
  | Eunload (path,base,ctx) -> String.concat " " ["Eunload"; path]
    
type event = (int64*event_details)

let parse_event bytes = 
  let id = parse_u64 bytes 0 in 
  let flags = parse_u64 bytes 8 in 
  let details = 
    (match flags with 
       | 2L -> 
	   let ctx = parse_ctx bytes 16 in Esyscall(ctx)
       | 4L -> 
	   let ctx = parse_ctx bytes 16 in
	     Eexec(ctx)
       | 8L -> 
	   let id = parse_u64 bytes 16 in 
	   let ctx1 = parse_ctx bytes 24 in 
	   let ctx2 = parse_ctx bytes (24 + ctxsize) in
	     Efork(id,ctx1,ctx2)
       | 16L -> 
	   let id = parse_u64 bytes 16 in 
	   let ctx1 = parse_ctx bytes 24 in 
	   let ctx2 = parse_ctx bytes (24 + ctxsize) in
	     Eclone(id,ctx1,ctx2)
       | 32L -> 
	   let ctx = parse_ctx bytes 16 in Esignal(ctx)
       | 64L -> Eexit
       | 128L -> 
	   let id = parse_u64 bytes 16 in
	   let ctx = parse_ctx bytes 24 in
	     Etrap(id,ctx)
       | 256L -> 
	   let id = parse_u64 bytes 16 in 
	   let id' = parse_u64 bytes 24 in 
	   let ctx = parse_ctx bytes 32 in
	     Esnap(id,id',ctx)
       (* | 512L -> Estepctx *) (* not a valid event *)
       | 1024L ->
	   let slen = Int64.to_int (parse_u64 bytes 16) in
	   let s = String.sub bytes 24 slen in
	   let base = parse_u64 bytes (24 + slen) in
	   let ctx = parse_ctx bytes (32 + slen) in
	   Eload (s,base,ctx)
       | 2048L ->
	   let slen = Int64.to_int (parse_u64 bytes 16) in
	   let s = String.sub bytes 24 slen in
	   let base = parse_u64 bytes (24 + slen) in
	   let ctx = parse_ctx bytes (32 + slen) in
	   Eunload (s,base,ctx)
       | _ -> raise Unsupported_message) in 
  (id,details)

type proc = {
  pid : int64;
  cmd : string;
  tids : int64 list;
}

let parse_procs (bytes:string) : proc array = 
  let nproc = (Int64.to_int (parse_u64 bytes 0)) in 
  let procs = Array.make nproc { pid=0L; cmd=""; tids=[];} in 
  let parse_proc (off:int) (idx:int) = 
    let id = parse_u64 bytes off in 
    let len = (Int64.to_int (parse_u64 bytes (off + 8))) in 
    let cmd = String.sub bytes (off + 16) len in  
    let ntid = (Int64.to_int (parse_u64 bytes (off + 16 + len))) in 
    let tids = ref [] in 
      for i = 0 to (ntid - 1) do 
	let tid = parse_u64 bytes (off + 24 + len + i * 8) in 
	  tids := tid :: !tids
      done;
      procs.(idx) <- {pid = id; cmd = cmd; tids = !tids};
      (off + 24 + len + ntid * 8) in 
  let off = ref 8 in 
    for i = 0 to (nproc - 1) do 
      off := parse_proc !off i;
    done;
    procs

type rflag = PROT_READ | PROT_WRITE | PROT_EXEC

type region = {
  r_file : string;
  r_addr: int64;
  r_len : int64;
  r_flags : rflag list;
  }

type binary = {
    b_nsid : int64;
    b_base : int64;
    b_isexe : bool;
    b_path : string;
  }

type stat = (int64*region array*binary array)


let parse_stat (bytes:string) : stat = 
  let pid = parse_u64 bytes 0 in 
  let nregs = (Int64.to_int (parse_u64 bytes 8)) in 
  let regs = Array.make nregs { r_file=""; r_addr=0L; r_len=0L; r_flags=[];} in 
  let parse_flags (x:int64) : rflag list = 
    let flags = ref [] in 
      if (Int64.logand x 1L) = 1L then 
	flags := PROT_READ :: !flags;
      if (Int64.logand x 2L) = 2L then 
	flags := PROT_WRITE :: !flags;
      if (Int64.logand x 4L) = 4L then 
	flags := PROT_EXEC :: !flags;
      !flags in 
  let parse_region (off:int) (idx:int)= 
    let flen = (Int64.to_int (parse_u64 bytes off)) in 
    let fname = String.sub bytes (off + 8) flen in
    let addr = parse_u64 bytes (off + 8 + flen) in 
    let len = parse_u64 bytes (off + 16 + flen) in 
    let oflags = parse_u64 bytes (off + 24 + flen) in
    begin
      regs.(idx) <- { r_file=fname; r_addr=addr; r_len=len; 
		      r_flags=(parse_flags oflags);} ; 
      (off + 32 + flen) 
    end in 
  let off = ref 16 in 
    for i = 0 to (nregs - 1) do 
      off := parse_region !off i
    done;
  let nbins = (Int64.to_int (parse_u64 bytes !off)) in
  off:=!off + 8;
  let bins = Array.make nbins { b_nsid=0L; b_base=0L;b_isexe=false;b_path="";} in
  let parse_binary (off:int) (idx:int)=
    let nsid = parse_u64 bytes off in
    let base = parse_u64 bytes (off + 8) in
    let isexe = 
      (match int_of_char bytes.[off + 16] with
	0 -> false
      | 1 ->true
      | _ -> assert false) in
    let plen = (Int64.to_int (parse_u64 bytes (off + 17))) in 
    let pname = String.sub bytes (off + 25) plen in
    begin
      bins.(idx) <- {b_nsid=nsid; b_base=base; b_isexe=isexe; b_path=pname;} ;
      (off + 25 + plen)
    end in
  for i = 0 to (nbins - 1) do
    off := parse_binary !off i
  done;
  (pid, regs, bins)

let format_rflags (rl : rflag list) : string =
  let rv = String.copy "---" in
  List.iter (fun el ->
    (match el with
      PROT_READ -> rv.[0] <- 'r'
    | PROT_WRITE -> rv.[1] <- 'w'
    | PROT_EXEC -> rv.[2] <- 'x')) rl;
  rv
  
(* Code to mirror sctl client code in l1/lib/sctl.cqct *)

type sctlstring = {
    len : int;
    s : string;
  }

let decodes (bytes:string) (off:int) : (string * int) =
  let len = Int64.to_int (parse_u64 bytes off) in
  let rs = String.sub bytes (off+8) len in
  (rs, off+8+len)

let tk2str (t:tname) : string =
  match t with
    Tvoid -> "Tvoid"
  | Tbase _ -> "Tbase"
  | Tstruct _ -> "Tstruct"
  | Tunion _ -> "Tunion"
  | Tenum _ -> "Tenum"
  | Tptr _ -> "Tptr"
  | Tarr _ -> "Tarr"
  | Tfun _ -> "Tfun"
  | Ttypedef _ -> "Ttypedef"
  | Tbitfield _ -> "Tbitfield"
  | Tconst _ -> "Tconst"
  | Txaccess -> "Txaccess"
  | Tundef _ -> "Tundef"

let tk2byte (t:tname) : int =
  match t with
    Tvoid -> 0
  | Tbase _ -> 1
  | Tstruct _ -> 2
  | Tunion _ -> 3
  | Tenum _ -> 4
  | Tptr _ -> 5
  | Tarr _ -> 6
  | Tfun _ -> 7
  | Ttypedef _ -> 8
  | Tbitfield _ -> 9
  | Tconst _ -> 10
  | Txaccess -> 11
  | Tundef _ -> 12

let decoderk (c:char) : rkind =
  match int_of_char c with
    0 -> Rundef
  | 1 -> Ru08le
  | 2 -> Ru16le
  | 3 -> Ru32le
  | 4 -> Ru64le
  | 5 -> Rs08le
  | 6 -> Rs16le
  | 7 -> Rs32le
  | 8 -> Rs64le
  | 9 -> Ru08be
  | 10 -> Ru16be
  | 11 -> Ru32be
  | 12 -> Ru64be
  | 13 -> Rs08be
  | 14 -> Rs16be
  | 15 -> Rs32be
  | 16 -> Rs64be
  | 17 -> Rf32
  | 18 -> Rf64
  | 19 -> Rf96
  | 20 -> Rf128
  | 21 -> Rx64
  | 22 -> Rx128
  | 23 -> Rx192
  | 24 -> Rnrep
  | _ as n ->
      ignore (Printf.fprintf stderr "exception in decoderk:%d\n" n);
      flush stderr;
      raise (Unexpected_type (string_of_int n))

let decodecb (c:char) : cbase =
  match int_of_char c with
    0 -> Vundef
  | 1 -> Vbool
  | 2 -> Vchar
  | 3 -> Vshort
  | 4 -> Vint
  | 5 -> Vlong
  | 6 -> Vvlong
  | 7 -> Vuchar
  | 8 -> Vushort
  | 9 -> Vuint
  | 10 -> Vulong
  | 11 -> Vuvlong
  | 12 -> Vfloat
  | 13 -> Vdouble
  | 14 -> Vlongdouble
  | 15 -> Vcomplex
  | 16 -> Vdoublex
  | 17 -> Vlongdoublex
  | 18 -> Vptr
  | 19 -> Vvoid
  | 20 -> Vnallbase
  | _ -> ignore (Printf.fprintf stderr "exception in decodecb\n"); flush stderr;
      raise (Unexpected_type (string_of_int (int_of_char c)))

let cb2str (cb : cbase) =
  match cb with
    Vundef -> "Vundef"
  | Vbool -> "Vbool"
  | Vchar -> "Vchar"
  | Vshort -> "Vshort"
  | Vint -> "Vint"
  | Vlong -> "Vlong"
  | Vvlong -> "Vvlong"
  | Vuchar -> "Vuchar"
  | Vushort -> "Vushort"
  | Vuint -> "Vuint"
  | Vulong -> "Vulong"
  | Vuvlong -> "Vuvlong"
  | Vfloat -> "Vfloat"
  | Vdouble -> "Vdouble"
  | Vlongdouble -> "Vlongdouble"
  | Vcomplex -> "Vcomplex"
  | Vdoublex -> "Vdoublex"
  | Vlongdoublex -> "Vlongdoublex"
  | Vptr -> "Vptr"
  | Vvoid -> "Vvoid"
  | Vnallbase -> "Vnallbase"

let cb2cstr (cb : cbase) =
  match cb with
    Vundef -> "Vundef"
  | Vbool -> "_Bool"
  | Vchar -> "char"
  | Vshort -> "short"
  | Vint -> "int"
  | Vlong -> "long"
  | Vvlong -> "long long"
  | Vuchar -> "unsigned char"
  | Vushort -> "unsigned short"
  | Vuint -> "unsigned int"
  | Vulong -> "unsigned long"
  | Vuvlong -> "unsigned long long"
  | Vfloat -> "float"
  | Vdouble -> "double"
  | Vlongdouble -> "longdouble"
  | Vcomplex -> "complex"
  | Vdoublex -> "doublex"
  | Vlongdoublex -> "longdoublex"
  | Vptr -> "ptr"
  | Vvoid -> "void"
  | Vnallbase -> "Vnallbase"

let rec formattype (t:tname) : string =
  match t with
    Tvoid -> "void"
  | Tbase (cb) -> Printf.sprintf "%s" (cb2cstr cb)
  | Tstruct (tag) -> Printf.sprintf "struct %s" tag
  | Tunion (tag) -> Printf.sprintf "union %s" tag
  | Tenum (tag) -> Printf.sprintf "enum %s" tag
  | Tptr (t1) -> Printf.sprintf "%s*" (formattype t1)
  | Tarr (n, t1) -> Printf.sprintf "%s[%d]" (formattype t1) n
  | Tfun (rt,_,pl) ->
      let s = formattype rt in
      let ps = String.concat ","
	  (List.map (fun p -> formattype p.p_type) pl) in
      Printf.sprintf "%s(%s)" s ps
  | Ttypedef (s) -> Printf.sprintf "%s" s
  | Tbitfield (w,p,t1) -> Printf.sprintf "%s:%d" (formattype t1) w
  | Tconst (t1) -> Printf.sprintf "const %s" (formattype t1)
  | Tundef (t1) -> Printf.sprintf "undefined %s" (formattype t1)
  | _ -> Printf.sprintf "tname without tdef"


(* type bitfld = *)

let rec decodetname (bytes:string) (off:int) : (tname * int) =
  match int_of_char bytes.[off] with
    0 -> (Tvoid, off+1)
  | 1 ->
      let cb = decodecb bytes.[off+1] in
      (Tbase (cb), off+2)
  | 2 ->
      let (s, endoff) = decodes bytes (off+1) in
      (Tstruct (s), endoff)
  | 3 ->
      let (s, endoff) = decodes bytes (off+1) in
      (Tunion (s), endoff)
  | 4 ->
      let (s, endoff) = decodes bytes (off+1) in
      (Tenum (s), endoff)
  | 5 ->
      let (reftype, endoff) = decodetname bytes (off+1) in
      (Tptr (reftype), endoff)
  | 6 ->
      let nelem = Int64.to_int (parse_u64 bytes (off+1)) in
      let (tn,newoff) = decodetname bytes (off+9) in
      (Tarr (nelem, tn), newoff)
  | 7 ->
      let (rettype,off2) = decodetname bytes (off+1) in
      let pcnt = Int64.to_int (parse_u64 bytes off2) in
      let plist = ref [] in
      let poff = ref (off2+8) in
      for i = 0 to (pcnt - 1) do
	let (pnt, nextoff) = decodeparam bytes !poff in
	ignore (plist := List.append !plist [pnt]);
	poff := nextoff
      done;
      (Tfun (rettype, pcnt, !plist), !poff)
  | 8 ->
      let (s, endoff) = decodes bytes (off+1) in
      (Ttypedef (s), endoff)
  | 9 ->
      let w = int_of_char bytes.[off] in
      let pos = int_of_char bytes.[off+1] in
      let (ftname, endoff) = decodetname bytes (off+2) in
      (Tbitfield (w, pos, ftname), endoff)
  | 10 ->
      let (tn,newoff) = decodetname bytes (off+1) in
      (Tconst (tn), newoff)
  | 11 ->
      (Txaccess, off+1)
  | 12 ->
      let (tn,newoff) = decodetname bytes (off+1) in
      (Tundef (tn), newoff)
  | _ as n ->
      ignore (Printf.fprintf stderr "exception in decodecbtname:%d\n" n);
      flush stderr;
      raise (Unexpected_type (string_of_int n))
	
and decodeparam (bytes:string) (off:int) : (param * int) =
  let attrcnt = parse_u64 bytes off in
  let (pn, newoff) = decodes bytes (off+8) in
  let (tn, endoff) = decodetname bytes newoff in
  ({ p_name = pn; p_type = tn}, endoff)

and decodefld (bytes:string) (off:int) : (field * int) =
  let foff = parse_u64 bytes off in
  let attrcnt =  parse_u64 bytes (off+8) in
  let (fname, toff) = decodes bytes (off+16) in
  let (ftype, endoff) = decodetname bytes toff in
  ({ f_off=off; f_alist=[]; f_name=fname; f_type=ftype; }, endoff)

and decodetdef (bytes:string) (off:int) : (tdef * int) =
  let (tn, newoff) = decodetname bytes off in
  match tn with
    Tbase (cb) ->
      let rk = decoderk bytes.[newoff] in
      ({ notype with st_tname=Tbase(cb); st_rep=Some(rk); } , newoff+1)
  | Tstruct (tag) | Tunion (tag) ->
      let size = parse_u64 bytes newoff in
      let attrcnt = parse_u64 bytes (newoff+8) in
      let fldcnt = Int64.to_int (parse_u64 bytes (newoff+16)) in
      let flist = ref [] in
      let foff = ref (newoff+24) in
      for i = 0 to (fldcnt-1) do
	let (f, newoff) = decodefld bytes !foff in
	flist := List.append !flist [f];
	foff := newoff
      done;
      ({ notype with st_tname=tn; st_id=Some(tag); st_sz=Some(size); st_flist=Some(!flist); }, !foff)
  | Tenum (tag) ->
      let rk = decoderk bytes.[newoff] in
      let ecnt = Int64.to_int (parse_u64 bytes (newoff+1)) in
      let eoff = ref (newoff+9) in
      let elist = ref [] in
      for i = 0 to (ecnt-1) do
	let (ename, valoff) = decodes bytes !eoff in
	let ev = parse_u64 bytes valoff in
	let en = { se_id=ename; se_off=ev;se_type=notype; } in
	elist := List.append !elist [en];
	eoff := valoff+8
      done;
      ({ notype with st_tname=tn; st_id=Some(tag); st_elist=Some(!elist); }, !eoff)
  | Ttypedef (s) ->
      let (reftn, endoff) = decodetname bytes newoff in
      ({ notype with st_tname=tn; st_id=Some(s); st_link=Some(reftn); }, endoff)
  | _ -> ignore (Printf.fprintf stderr "exception in decodetdef\n"); flush stderr;
      raise (Unexpected_type ("No such type definition"))
    

type sflag = SUNDEF | SDATA | STEXT | SRO |SENUM | SINLINE

type sym = {
    s_name : string;
    s_flags : sflag list;
    s_val : int64;
    s_size : int64;
    s_type : tname;
}

let nosym:sym = { s_name="";s_flags=[];s_val=0L;s_size=0L;s_type=Tundef(Tvoid);}
type symtab = (string, sym) HT.t

let parse_sym (sbytes:string) : (sym * int) =
  let parse_flags (c:char) : sflag list =
    let x = Int64.of_int (int_of_char c) in
    let flags = ref [] in 
    if (Int64.logand x 1L) = 1L then 
      flags := SUNDEF :: !flags;
    if (Int64.logand x 2L) = 2L then 
      flags := SDATA :: !flags;
    if (Int64.logand x 3L) = 2L then 
      flags := STEXT :: !flags;
    if (Int64.logand x 4L) = 2L then 
      flags := SRO :: !flags;
    if (Int64.logand x 5L) = 2L then 
      flags := SENUM :: !flags;
    if (Int64.logand x 6L) = 2L then 
      flags := SINLINE :: !flags;
    !flags in
  let len = Int64.to_int (parse_u64 sbytes 0) in
  let name = String.sub sbytes 8 len in
  let sflags = parse_flags sbytes.[8+len] in
  let sval = parse_u64 sbytes (8+len+1) in
  let attrcnt =parse_u64 sbytes (17+len) in
  let size = parse_u64 sbytes (25+len) in
  let (tname, endoff) = decodetname sbytes (33+len) in
  let s = { s_name=name; s_flags=sflags; s_val=sval; s_size=size; s_type=tname;} in
  (s, endoff)

let formatsym (s:sym) : string =
  Printf.sprintf "0x%Lx\t%s" s.s_val s.s_name

let formatsymsize (s:sym) : string =
  Printf.sprintf "0x%Lx\t0x%Lx\t%s" s.s_val s.s_size s.s_name

let parse_syms (bytes:string) (st:symtab) : unit =
  let nsyms = Int64.to_int (parse_u64 bytes 0) in
  (* let syms = Array.make nsyms { s_name=""; s_flags=[]; s_val=0L; s_size=0L; s_type=Tundef(Tvoid);} in  *)
  let off = ref 8 in
  let bcnt = String.length bytes in
  for i = 0 to (nsyms - 1) do 
    let (ns, newoff) = parse_sym (String.sub bytes !off (bcnt - !off)) in
    HT.add st ns.s_name ns;
    (* ignore (syms.(i) <- ns); *)
    off := !off+newoff
  done

type trapmode = Trap | Snap

let newtag =
let tagcntr = ref 0l in 
  fun () -> 
    tagcntr := Int32.succ !tagcntr;
    !tagcntr 

let rec runtiltag (tag:int32) (ic:in_channel) : msg = 
  let msg = readmsg ic in 
    if msg.tag = tag then 
      msg
    else 
      runtiltag tag ic

let rec runtilevent (ic:in_channel) : event = 
  let msg = readmsg ic in 
    if msg.op = Aevent then 
      parse_event (val_of msg.bytes)
    else 
      runtilevent ic
	
let checkmsg (msg:msg) (op:opCode) : unit = 
  if (msg.op <> op) then 
    bad_msg msg
  else 
    ()

let sendrcv (msg:msg) (p:sctl) : msg = 
  writemsg msg p.oc;
  runtiltag msg.tag p.ic

let negotiate_version (ic:in_channel) (oc:out_channel) : protovers = 
  let versmsg = { empty_msg with op=Tversion; tag=newtag(); 
		    bytes=Some("sctl-2012:x86-linux-2012,x86-win-2012"); } in 
  let _ = writemsg versmsg oc in 
  let msg = runtiltag versmsg.tag ic in 
    checkmsg msg Rversion;
    match msg.bytes with 
	Some("sctl-2012:x86-linux-2012") -> 
	  X86Linux2012
      | Some("sctl-2012:x86-win-2012") -> 
	  X86Win2012
      | Some b -> bad_prot (Printf.sprintf "unexpected protcol %s" b)
      | _ -> bad_msg msg


(* Sctl functions *)
let close (p:sctl) : unit = 
  match p.ptype with 
    | Local(pid) ->
	Unix.shutdown (Unix.descr_of_out_channel p.oc) Unix.SHUTDOWN_ALL;
	ignore(Unix.waitpid [] pid)
    | Remote(_,_) -> 
	Unix.shutdown_connection p.ic

let create_remote (host:string) (port:int) : sctl = 
  let addr = Unix.ADDR_INET(Unix.inet_addr_of_string host, port) in
  let in_chan,out_chan = Unix.open_connection(addr) in
  let vers = negotiate_version in_chan out_chan in 
   let rv =
   { 
      ptype = Remote(host,port);
      ic = in_chan;
      oc = out_chan;
      vers = vers;
    } in
  at_exit (fun () -> try close rv with Unix.Unix_error (_,"waitpid",_) -> (););
  rv

let create_local () : sctl = 
  let (mysock,sctlsock) = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in 
  let pid = Unix.create_process 
    "sctl" [| "sctl"; "-c"; |] sctlsock Unix.stdout Unix.stderr in 
  let _ = Unix.close sctlsock in 
  let in_chan = Unix.in_channel_of_descr mysock in 
  let out_chan = Unix.out_channel_of_descr mysock in 
  let vers = negotiate_version in_chan out_chan in
  let rv =
    {
      ptype = Local(pid);
      ic = in_chan;
      oc = out_chan;
      vers = vers;
    } in
  at_exit (fun () -> try close rv with Unix.Unix_error (_,"waitpid",_) -> (););
  rv

let ps (p:sctl) : proc array = 
  let msg = sendrcv { empty_msg with op=Tps; tag=newtag();} p in 
    checkmsg msg Rps;
    parse_procs (val_of msg.bytes)
	
let ping (p:sctl) (s:string) : unit = 
  let msg = sendrcv { empty_msg with op=Tping; tag=newtag(); 
			bytes=Some(s);} p in 
  let _ = checkmsg msg Rping in 
  let cnt = (val_of msg.cnt) in 
    if (Int64.to_int cnt) = (String.length s) then 
      ()
    else 
      bad_prot (Printf.sprintf "Bad ping size returned: %Ld" cnt)
	
let launch (p:sctl) (flags:launch_flag list) (cmd:string list) : (ctlproc*ctx) = 
  let buf = Buffer.create 10 in 
  let _ = append_u64 (launch_flags_to_int64 flags) buf in 
  let _ = append_u64 (Int64.of_int (List.length cmd)) buf in 
  let _ = List.iter (fun x -> append_u64 (Int64.of_int (String.length x)) buf; 
		       Buffer.add_string buf x) cmd in
  let msg = sendrcv { empty_msg with op=Tlaunch; tag=newtag(); 
			bytes=Some(Buffer.contents buf);} p in 
    checkmsg msg Rlaunch;
    let id = (val_of msg.Msg.id) in 
    let b  = (val_of msg.bytes) in 
      Printf.printf "Launched id %Ld\n" id;
      ({ 
	 sctl = p;
	 id = id;
       },
       parse_ctx b 0)
	
let attach (p:sctl) (pid:int64) : (ctlproc*ctx) = 
  let msg = sendrcv { empty_msg with op=Tattach; tag=newtag(); 
			Msg.id=Some(pid);} p in
  let _ = checkmsg msg Rattach in 
  let id = (val_of msg.Msg.id) in 
  let b = (val_of msg.bytes) in 
    Printf.printf "Attached to id %Ld\n" id;
    ({ 
       sctl = p;
       id = id;
     },
     parse_ctx b 0)
	

(* ctlproc functions *)
let step (p:ctlproc) : ctx = 
  let msg = sendrcv { empty_msg with op=Tstep; tag=newtag(); 
			Msg.id=Some(p.id);} p.sctl in
    checkmsg msg Rstep;
    parse_ctx (val_of msg.bytes) 0


let cont (p:ctlproc) : unit = 
  checkmsg (sendrcv { empty_msg with op=Tcont; tag=newtag(); Msg.id=Some(p.id)} 
	      p.sctl) Rcont

      
let cont_to_exit (p:ctlproc) : unit = 
  cont p; 
  while (match (runtilevent p.sctl.ic) with 
	     (id,Eexit) -> (id <> p.id)
	   | (_) -> cont p; true) do
    ()
  done
      

let stop (p:ctlproc) : ctx = 
  let msg = sendrcv { empty_msg with op=Tstop; tag=newtag(); 
			Msg.id=Some(p.id);} p.sctl in 
  let _ = checkmsg msg Rstop in 
    parse_ctx (val_of msg.bytes) 0
	

let detach (p:ctlproc) : unit = 
  checkmsg (sendrcv {empty_msg with op=Tdetach; tag=newtag(); 
		       Msg.id=Some(p.id);} p.sctl) Rdetach	

let stat (p:ctlproc) : stat = 
  let msg = sendrcv { empty_msg with op=Tstat; tag=newtag(); 
			Msg.id=Some(p.id);} p.sctl in 
  let _ = checkmsg msg Rstat in 
    parse_stat (val_of msg.bytes)


let snap (p:ctlproc) : ctlproc = 
  let msg = sendrcv { empty_msg with op=Tsnap; tag=newtag();
			Msg.id=Some(p.id);} p.sctl in 
  let _ = checkmsg msg Rsnap in 
    {
      sctl = p.sctl;
      id = (val_of msg.Msg.id);
    }

let kill (p:ctlproc) : unit = 
  checkmsg (sendrcv {empty_msg with op=Tkill; tag=newtag(); 
		       Msg.id=Some(p.id);} p.sctl) Rkill	


let trace (p:ctlproc) (flags:trace_flag list) : unit = 
  let buf = Buffer.create 8 in 
    append_u64 (trace_flags_to_int64 flags) buf;
    checkmsg (sendrcv { empty_msg with op=Ttrace; tag=newtag();
			  Msg.id=Some(p.id); 
			  bytes=Some(Buffer.contents buf);} p.sctl)
      Rtrace

let settrap (p:ctlproc) (mode:trapmode) (addr:int64) : int64 = 
  let buf = Buffer.create 16 in 
  let _ = append_u64 (match mode with 
			| Trap -> 0L
			| Snap -> 1L) buf in 
  let _ = append_u64 addr buf in 
  let msg = sendrcv { empty_msg with op=Tsettrap; tag=newtag();
			Msg.id=Some(p.id);
			bytes=Some(Buffer.contents buf);} p.sctl in 
  let _ = checkmsg msg Rsettrap in 
    val_of msg.tid


let cleartrap (p:ctlproc) (tid:int64) : unit = 
  checkmsg (sendrcv {empty_msg with op=Tclrtrap; tag=newtag(); 
		       Msg.id=Some(p.id); tid=Some(tid);} p.sctl) Rclrtrap

let getctx (p:ctlproc) : ctx = 
  let msg = (sendrcv {empty_msg with op=Tgetctx; tag=newtag(); 
			Msg.id=Some(p.id);} p.sctl) in 
  let _ = checkmsg msg Rgetctx in 
    parse_ctx (val_of msg.bytes) 0


let setctx (p:ctlproc) (ctx:ctx) : unit = 
  let ctxstr = format_ctx ctx in 
    checkmsg (sendrcv {empty_msg with op=Tsetctx; tag=newtag(); 
			 Msg.id=Some(p.id); bytes=Some(ctxstr);} p.sctl)
      Rsetctx

let readmem (p:ctlproc) (off:int64) (cnt:int64) : string = 
  let msg = sendrcv { empty_msg with op=Tread; tag=newtag();
			Msg.id=Some(p.id); fd=Some(-1L); 
			addr=Some(off); cnt=Some(cnt);} p.sctl in 
  let _ = checkmsg msg Rread in 
    val_of msg.bytes

let writemem (p:ctlproc) (off:int64) (bytes:string) : int64 = 
  let msg = sendrcv { empty_msg with op=Twrite; tag=newtag();
			Msg.id=Some(p.id); fd=Some(-1L);
			addr=Some(off); bytes=Some(bytes);} p.sctl in 
  let _ = checkmsg msg Rwrite in 
    val_of msg.cnt

(* namespace functions *)
let ns (path:string) : sctlns =
  let msg = { empty_msg with op=Tnames;tag=newtag(); bytes=Some(path);} in
  let sc = create_local () in
  writemsg msg sc.oc;
  let rmsg = runtiltag msg.tag sc.ic in
  let rv =
    (match rmsg.op with
      Rnames -> 
	(match rmsg.Msg.bytes with
	  Some x -> parse_u64 x 0
	| None -> 0L)
    | _  -> raise (Unexpected_message (String.concat "" ["NS request failed for "; path]))) in
  { ns_id=rv; ns_sctl=sc; }

let looksym (ns:sctlns) (sym:string) : sym =
  let msg = { empty_msg with op=Tlooksym;tag=newtag(); bytes = Some (sym); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let rv =
    (match rmsg.op with
      Rlooksym ->
	(match rmsg.Msg.bytes with
	  Some x ->
	    let (rsym, _) = parse_sym x in
	    rsym
	| None -> nosym)
    | _ -> ignore (Printf.fprintf stderr "Couldn't find %s in ns %Ld\n"
		     sym ns.ns_id);
	nosym) in
  rv

let enumsym (ns:sctlns) : symtab =
  let st:symtab = HT.create 163 in
  let msg = { empty_msg with op=Tenumsym;tag=newtag(); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  (match rmsg.op with
    Renumsym ->
      (match rmsg.Msg.bytes with
	Some x -> parse_syms x st
      | None -> raise (Unexpected_message "Couldn't get syms for ns\n"))
  | _ -> raise (Unexpected_message "Couldn't get syms for ns\n"));
  st
  
let rec parse_lexpr (bytes:string) (off:int) : (sctllexpr * int) =
  match int_of_char bytes.[off] with
    0 -> (Lreg (int_of_char bytes.[off+1]), off+2)
  | 1 -> let (lex,off1) = parse_lexpr bytes (off+1) in
    (Lderef lex, off1)
  | 2 ->
      let (op1, off1) = parse_lexpr bytes (off+1) in
      let (op2, off2) = parse_lexpr bytes (off1) in
      (Ladd (op1, op2), off2)
  | 3 ->
      let (op1, off1) = parse_lexpr bytes (off+1) in
      let (op2, off2) = parse_lexpr bytes (off1) in
      (Lsub (op1, op2), off2)
  | 4 ->
      let uval = parse_u64 bytes (off+1) in
      (Lulit uval, off+9)
  | 5 ->
      let sval = parse_u64 bytes (off+1) in
      (Lslit sval, off+9)
  | _ -> raise Unexpected_lexpr

let rec format_lexpr (s:sctllexpr) : string =
  match s with
    Lreg (regno) -> Printf.sprintf "Reg %d" regno
  | Lderef (l) -> Printf.sprintf "*(%s)" (format_lexpr l)
  | Ladd (op1, op2) ->
      Printf.sprintf "%s + %s" (format_lexpr op1) (format_lexpr op2)
  | Lsub (op1, op2) -> 
      Printf.sprintf "%s - %s" (format_lexpr op1) (format_lexpr op2)
  | Lulit uval -> Printf.sprintf "0x%Lx" uval
  | Lslit uval -> Printf.sprintf "0x%Lx" uval

let parse_loc (bytes:string) (off:int) : (sctlloc * int) =
  let nlen = Int64.to_int (parse_u64 bytes off) in
  let id = String.sub bytes (off+8) nlen in
  let (tname, toff) = decodetname bytes (off+8+nlen) in
  let kind =
    (match int_of_char (bytes.[toff]) with
      0 -> L_var
    | 1 -> L_param
    | _ -> raise Invalid_location_kind) in
  let loff = (toff+1) in
  let (lexpr, newoff) = parse_lexpr bytes loff in
  ({ sl_id=id; sl_type=tname; sl_kind=kind; sl_lexpr=lexpr; }, newoff)

let enumloc (ns:sctlns) (addr:int64) : loctab =
  let lt:loctab = HT.create 113 in
  let bytes = u64tostr addr in
  let msg = { empty_msg with op=Tenumloc;tag=newtag(); Msg.id=Some(ns.ns_id);
	    Msg.bytes = Some (bytes);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  (match rmsg.op with
    Renumloc ->
      let bytes =
	match rmsg.bytes with
	  Some x -> x
	| None -> raise (Unexpected_message "No bytes for Renumloc") in
      let nl = Int64.to_int (parse_u64 bytes 0) in
      let slist = ref [] in
      let loff = ref 8 in
	for i = 0 to (nl-1) do
	  let (l,no) = parse_loc bytes !loff in
	  slist := List.append !slist [l];
	  loff := no
	done;
      HT.add lt addr (addr, !slist)
  | _ -> raise (Unexpected_message "bad enumloc reply"));
  lt
	
let rec formatparam (p:param) : string =
  let s = u64tostr 0L in
  Printf.sprintf "%s%s%s%s" s (u64tostr (Int64.of_int (String.length p.p_name)))
    p.p_name (formattname p.p_type)

and formattname (t:tname) : string =
  match t with
    Tvoid -> Printf.sprintf "%c" (char_of_int 0)
  | Tbase (cb) -> Printf.sprintf "%c%s" (char_of_int 1) (cb2cstr cb)
  | Tstruct (tag) -> Printf.sprintf "%c%s%s" (char_of_int 2)
	(u64tostr (Int64.of_int (String.length tag))) tag
  | Tunion (tag) -> Printf.sprintf "%c%s%s" (char_of_int 3)
	(u64tostr (Int64.of_int (String.length tag))) tag
  | Tenum (tag) -> Printf.sprintf "%c%s%s" (char_of_int 4)
	(u64tostr (Int64.of_int (String.length tag))) tag
  | Tptr (t1) -> Printf.sprintf "%c%s" (char_of_int 5) (formattname t1)
  | Tarr (n, t1) -> Printf.sprintf "%c%s%s" (char_of_int 6)
	(u64tostr (Int64.of_int n)) (formattname t1)
  | Tfun (rt,_,pl) ->
      let s = ref (Printf.sprintf "%c%s" (char_of_int 7) (formattname rt)) in
      let pcnt = List.length pl in
      s := Printf.sprintf "%s%s" !s (u64tostr (Int64.of_int pcnt));
      for i = 0 to (pcnt-1) do
	s := Printf.sprintf "%s%s" !s (formatparam (List.nth pl i))
      done;
      !s
  | Ttypedef (s) -> Printf.sprintf "%c%s%s" (char_of_int 8)
	(u64tostr (Int64.of_int (String.length s))) s
  | Tbitfield (w,p,t1) -> Printf.sprintf "%c%c%c%s" (char_of_int 9)
	 (char_of_int w) (char_of_int p) (formattname t1)
  | Tconst (t1) -> Printf.sprintf "%c%s" (char_of_int 10) (formattname t1)
  | Tundef (t1) -> Printf.sprintf "%c%s" (char_of_int 12) (formattname t1)
  | _ -> Printf.sprintf "tname without tdef"

  

let looktype (ns:sctlns) (tn:tname) : tdef =
  let bytes = formattname tn in
  let msg = { empty_msg with op=Tlooktype;tag=newtag(); bytes = Some (bytes); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let rv =
    (match rmsg.op with
      Rlooktype ->
	(match rmsg.Msg.bytes with
	  Some x ->
	    let (rtdef, _) = decodetdef x 0 in
	    rtdef
	| None -> notype)
    | _ -> ignore (Printf.fprintf stderr "Couldn't find %s in ns %Ld\n"
		     bytes ns.ns_id);
	notype) in
  rv

let parse_tdefs (bytes:string) : typetab =
  let tt:typetab = HT.create 113 in
  let ntdefs = Int64.to_int (parse_u64 bytes 0) in
  (* let tdefs = Array.make ntdefs notype in *)
  let off = ref 8 in
  for i = 0 to (ntdefs - 1) do 
    let (nt, newoff) = decodetdef bytes !off in
    HT.add tt (formattname nt.st_tname) nt;
    (* ignore (tdefs.(i) <- nt); *)
    off := newoff
  done;
  tt
  
let enumtype (ns:sctlns) : typetab =
  let msg = { empty_msg with op=Tenumtype;tag=newtag(); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  match rmsg.op with
    Renumtype -> 
      (match rmsg.Msg.bytes with
	Some x -> parse_tdefs x
      | None -> raise (Unexpected_message "Couldn't get types for ns\n"))
  | _ -> raise (Unexpected_message "Couldn't get types for ns\n")

let lookaddr (ns:sctlns) (addr:int64) : sym =
  let bytes = u64tostr addr in
  let msg = { empty_msg with op=Tlookaddr;tag=newtag(); bytes = Some (bytes); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let rv =
    (match rmsg.op with
      Rlookaddr ->
	(match rmsg.Msg.bytes with
	  Some x ->
	    let (rsym, _) = parse_sym x in
	    rsym
	| None -> nosym)
    | _ -> ignore (Printf.fprintf stderr "Couldn't find %Ld in ns %Ld\n"
		     addr ns.ns_id);
	nosym) in
  rv

let parse_seg (bytes:string) (off:int) : (sym * int) =
  let sval = parse_u64 bytes off in
  let size = parse_u64 bytes (off+8) in
  let (name, endoff) = decodes bytes (off+16) in
  let s = { nosym with s_name=name; s_val=sval; s_size = size; } in
  (s, endoff)

let parse_segs (bytes:string) : sym array =
  let nsyms = Int64.to_int (parse_u64 bytes 0) in
  let syms = Array.make nsyms { s_name=""; s_flags=[]; s_val=0L; s_size=0L; s_type=Tundef(Tvoid);} in 
  let off = ref 8 in
  for i = 0 to (nsyms - 1) do 
    let (ns, newoff) = parse_seg bytes !off in
    ignore (syms.(i) <- ns);
    off := newoff
  done;
  syms

let enumseg (ns:sctlns) : sym array =
  let msg = { empty_msg with op=Tenumseg;tag=newtag(); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let rv =
    (match rmsg.op with
      Renumseg -> 
	(match rmsg.Msg.bytes with
	  Some x -> parse_segs x
	| None -> Array.make 1 nosym)
    | _ -> raise (Unexpected_message "Couldn't get enumseg for ns\n")) in
  rv

let parse_srcloc (bytes:string) : srcloc =
  let (file, lineoff) = decodes bytes 0 in
  let line = parse_u32 bytes lineoff in
  let col = parse_u32 bytes (lineoff+4) in
  { src_addr=0L; src_file=file; src_line=line; src_col=col; }

let looksrc (ns:sctlns) (addr:int64) : srcloc =
  let bytes = u64tostr addr in
  let msg = { empty_msg with op=Tlooksrc;tag=newtag(); bytes = Some (bytes); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let noloc = { src_addr=0L; src_file=""; src_line=0l; src_col=0l; } in
  let rv =
    (match rmsg.op with
      Rlooksrc ->
	(match rmsg.Msg.bytes with
	  Some x ->
	    let rloc = parse_srcloc x in
	    rloc
	| None -> noloc)
    | _ -> ignore (Printf.fprintf stderr "Couldn't find src for 0x%Lx in ns %Ld\n"
		     addr ns.ns_id);
	flush_all();
	raise (Unexpected_message "No source info for addr")) in
  { rv with src_addr=addr; }

let lookpc (ns:sctlns) (file:string) (line:int) : int64 =
  let slen = String.length file in
  let bytes = String.concat "" [u64tostr (Int64.of_int slen);file;u32tostr (Int32.of_int line)] in
  let msg = { empty_msg with op=Tlookpc;tag=newtag(); bytes = Some (bytes); Msg.id=Some(ns.ns_id);} in
  writemsg msg ns.ns_sctl.oc;
  let rmsg = runtiltag msg.tag ns.ns_sctl.ic in
  let rv =
    (match rmsg.op with
      Rlookpc ->
	(match rmsg.Msg.bytes with
	  Some x -> parse_u64 x 0
	| None -> raise (Unexpected_message "no lookpc result"))
    | _ -> ignore (Printf.fprintf stderr "Couldn't find pc for %s:%d in ns %Ld\n"
		     file line ns.ns_id);
	0L) in
  rv

let skip_prologue (ns:sctlns) (fname:string) : (int64 * int64) option =
  let fsym = looksym ns fname in
  let isfunc f =
    (match f.s_type with
      Tfun _ -> true
    | _ -> false) in
  if not (isfunc fsym) then
    None
  else begin
    let pfinished = ref false in
    let ep = ref fsym.s_val in
    let cura = ref fsym.s_val in
    let entry = looksrc ns !ep in
    let ll = ref entry.src_line in
    let reset = ref true in
    let rec nsl (addr:int64) (line:int32) : int64 * int32 =
      let a = Int64.add addr 1L in
      let sl = looksrc ns a in
      if sl.src_line = line then
	nsl a line
      else
	(a, sl.src_line) in
    while not !pfinished do
      try
	let (newa, news) = nsl !cura !ll in
	cura := newa;
	ll := news;
	if !reset then begin
	  ep := newa;
	  reset := false
	end;
	if news = entry.src_line then
	  reset := true;
	if Int64.sub newa fsym.s_val > 100L && news <> entry.src_line then
	  pfinished := true
      with Unexpected_message _ -> pfinished := true
    done;
    Some (fsym.s_val, !ep)
  end