(**************************************************************************)
(*                                                                        *)
(*  Ocamlviz --- real-time profiling tools for Objective Caml             *)
(*  Copyright (C) by INRIA - CNRS - Universite Paris Sud                  *)
(*  Authors: Julien Robert                                                *)
(*           Guillaume Von Tokarski                                       *)
(*           Sylvain Conchon                                              *)
(*           Jean-Christophe Filliatre                                    *)
(*           Fabrice Le Fessant                                           *)
(*  GNU Library General Public License version 2                          *)
(*  See file LICENSE for details                                          *)
(*                                                                        *)
(**************************************************************************)

open Binary
open Protocol

(*

msg:

  nb_byte :   1 |  2  |  1   |     4       | name length
             -------------------------------------
  declare   | 0 | tag | kind | name length | name |
             -------------------------------------

  nb_byte :   1 |  2  | 
             ------------------
  send      | 1 | tag | Value  |
             ------------------

  nb_byte :   2 |    4  
             --------------
  bind      | 2 | tag list |
             --------------


Value :

  nb_byte :   1 |  4
             ---------
  Int i     | 0 |  i  |
             ---------

  nb_byte :   1 |  8
             ---------
  Int i     | 1 |  i  |
             ---------

  nb_byte :     1 |  8
               ---------
  Float f     | 2 |  f  |
               ---------

  nb_byte :   1 |    4     | length
             ------------------
  String s  | 3 |  length  | s |
             ------------------

  nb_byte :    1 |  1
              ---------
  Bool b     | 4 |  b  |
              ---------


  nb_byte :     1 |  8
               ---------
  Int64 i     | 5 |  i  |
               ---------


  nb_byte :    1 
              ---
  Collected  | 6 |
              ---


  nb_byte :   1
             ---
  Int i     | 7 |
             ---


  nb_byte :   1 |    1
             -----------------------------  
  Tree      | 8 | # nodes | List of nodes |
             -----------------------------

  nb_byte :          4    | length |     1      |
                -----------------------------------------------------
  node (s,l) : |  length  |    s   | # children | List of # children |         
                -----------------------------------------------------

  nb_byte :          2
               --------------
  child       | index of DFS |
               --------------

example tree :

       A
      / \
     B   C
    / \
   D   E

   
     | # nodes | length D |   | 0 child | length E |   | 0 child | length B |   | 2 children | node 0 | node 1 |
  -------------------------------------------------------------------------------------------------------------
 | 8 |    5    |     1    | D |    0    |     1    | E |    0    |     1    | B |    2       |    0   |    1   | -> 
  -------------------------------------------------------------------------------------------------------------
               |         node 0         |         node 1         |          node 2                             |


     | length C |   | 0 child | length A |   | 2 children | node 2 | node 3 |
      ----------------------------------------------------------------------
  -> |     1    | C |    0    |     1    | A |    2       |    2   |   3    | 
      ----------------------------------------------------------------------
     |          node 3        |           node 4                            |



*)



module HB = 
  Hashtbl.Make(struct 
		 type t = variant
		 let equal = (==) 
		 let hash = Hashtbl.hash end)

module HG = 
  Hashtbl.Make(struct 
		 type t = int
		 let equal = (=) 
		 let hash = Hashtbl.hash end)
 

let buf_kind buf k = 
  let i = 
    match k with
      | Point -> 0
      | Time -> 1
      | Value_int -> 2
      | Value_float -> 3
      | Value_bool -> 4
      | Value_string -> 5
      | Tag_count -> 6
      | Tag_size -> 7
      | Special -> 8
      | Ktree -> 9
      | Hash -> 10
      | Klog -> 11
  in
  buf_int8 buf i


let buf_tree buf n =  
  let i = ref 0 in
  let h = HB.create 17 in
  let res = ref [] in
  let rec buf_node (Node (s,l) as n) =
    try
      HB.find h n
    with Not_found ->
      let l = List.map buf_node l in
      let j = !i in
      incr i;
      HB.add h n j;
      res := (s, l) :: !res;
      j
  in
  ignore (buf_node n);
  let buf_elt buf (s,l) =
    buf_string31 buf s;
    buf_list16 buf_int16 buf l
  in
  buf_list16 buf_elt buf (List.rev !res)


let buf_bind buf l = 
  buf_list16 buf_int16 buf l


let buf_printf buf e = 
  let t,v = e in
  buf_float buf t;
  buf_string31 buf v


let rec buf_value buf = function
  | Int i -> begin match Sys.word_size with
      |32 -> buf_int8 buf 0; buf_int31 buf i
      |64 -> buf_int8 buf 1; buf_int63 buf i
      |_ -> assert false
    end
  | Float f -> buf_int8 buf 2; buf_float buf f
  | String s -> buf_int8 buf 3; buf_string31 buf s
  | Bool b -> buf_int8 buf 4; buf_bool buf b
  | Int64 i -> buf_int8 buf 5; buf_int64 buf i
  | Collected -> buf_int8 buf 6
  | Killed -> buf_int8 buf 7
  | Tree v -> buf_int8 buf 8;buf_tree buf v
  | Hashtable (l,nb,empty,max) -> buf_int8 buf 9;buf_value buf l;buf_value buf nb;buf_value buf empty;buf_value buf max
  | Log l -> buf_int8 buf 10; buf_list16 buf_printf buf l
  | No_value -> assert false


let buf_msg buf = function
  |Declare (t,k,n) -> 
     buf_int8 buf 0;
      buf_int16 buf t;
      buf_kind buf k;
      buf_string31 buf n
      	
  |Send (t,v) -> 
     buf_int8 buf 1;
      buf_int16 buf t;
      buf_value buf v     
	
  |Bind l -> 
     buf_int8 buf 2;
      buf_bind buf l

(* Fabrice: I added a global buffer [tmp_buf] for message encoding. In [encode_one], a message is
first encoded in the temporary buffer, to compute its size, and the content
of the temporary   buffer is then added to the final buffer, after
  its size *)
      
let tmp_buf = Buffer.create 65000
      
let encode_one b msg = 
  Buffer.clear tmp_buf;
  buf_msg tmp_buf msg;
  buf_int31 b (Buffer.length tmp_buf);
  Buffer.add_buffer b tmp_buf


let encode buf msgs = List.iter (encode_one buf) msgs


let get_string31 s pos last = 
  if pos > last-4 then raise IncompleteMessage;
  let len,pos = get_int31 s pos in
  if pos > last-len then raise IncompleteMessage;
  get_string s pos len


let get_printf s pos last =
  if pos > last-8 then raise IncompleteMessage;
  let f,pos = get_float s pos in
  let s,pos = get_string31 s pos last in
  (f,s),pos

(* let get_array l i = *)
(*   let a = Array.make i "" in *)
(*   let idx = ref 0 in *)
(*   List.iter (fun elt -> a.(!idx) <- elt ; incr idx) l; *)
(*   a *)

let get_kind s pos = 
  let k = get_uint8 s pos in
  let kind =
    match k with

      | 0 -> Point
      | 1 -> Time
      | 2 -> Value_int
      | 3 -> Value_float
      | 4 -> Value_bool
      | 5 -> Value_string
      | 6 -> Tag_count 
      | 7 -> Tag_size
      | 8 -> Special
      | 9 -> Ktree
      | 10 -> Hash
      | 11 -> Klog
      | _ -> Format.eprintf "kind:%d@." k;assert false
  in
  kind,pos+1


let safe_get_int16 s pos last =
  if pos > last-2 then raise IncompleteMessage;
  get_int16 s pos


let dump msg s pos last =
  Format.eprintf "%s: pos=%d last=%d:@." msg pos last;
  for i = max 0 (pos-10) to last-1 do
    if i = pos then Format.eprintf "|";
    Format.eprintf "%03d " (Char.code s.[i])
  done;
  Format.eprintf "@.";
  for i = max 0 (pos-10) to last-1 do
    if i = pos then Format.eprintf "|";
    Format.eprintf "%c   " (let c = s.[i] in if c >= 'A' && c <= 'z' then c else '.')
  done;
  Format.eprintf "@."

open Format

let get_tree s pos last =
  (* dump "get_tree" s pos last; *)
  let get_elt s pos last =
    let n, pos = get_string31 s pos last in
    let l, pos = get_list16 safe_get_int16 s pos last in
    (n, l), pos
  in
  let l, pos = get_list16 get_elt s pos last in
  let h = HG.create 17 in
  let i = ref 0 in
  List.iter
    (fun (s,l) -> 
       let n = Node (s, List.map (HG.find h) l) in
       (* Format.eprintf "get_tree: %d -> %s@." !i s; *)
       HG.add h !i n;
       incr i)
    l;
  HG.find h (!i - 1), pos


let rec get_value s pos last = 
  let t = get_uint8 s pos in
  match t with
    |0 -> 
       begin match Sys.word_size with
	 |32 -> if pos+1 > last-4 then raise IncompleteMessage;
	     let x,pos = get_int31 s (pos+1) in
	     Int x,pos
	 |64 -> if pos+1 > last-4 then raise IncompleteMessage;
	     let x,pos = get_int63_of_31 s (pos+1) in
	     Int x,pos
	 |_ ->assert false 
       end
    |1 -> 
       begin match Sys.word_size with
	 |32 -> if pos+1 > last-8 then raise IncompleteMessage;
	     let x,pos = get_int64_of_63 s (pos+1) in
	     Int64  x,pos
	 |64 -> if pos+1 > last-8 then raise IncompleteMessage;
	     let x,pos = get_int63 s (pos+1) in
	     Int x,pos
	 |_ ->assert false 
       end
    |2 -> 
       if pos+1 > last-8 then raise IncompleteMessage;
	 let x,pos = get_float s (pos+1) in
	 Float x,pos
    |3 ->
       let v,pos = get_string31 s (pos+1) last in
       String v,pos
    |4 ->
       if pos+1 > last-1 then raise IncompleteMessage;
	 let x = get_bool s (pos+1) in
	 Bool x ,pos+2
    |5 -> 
       if pos+1 > last-8 then raise IncompleteMessage;
	 let x,pos = get_int64 s (pos+1) in
	 Int64 x,pos
    |6 -> 
       Collected, pos+1
    |7 -> 
       Killed, pos+1
    |8 -> 
       let tr,pos = get_tree s (pos+1) last in
       Tree tr,pos
    |9 -> 
       let l,pos = get_value s (pos+1) last in
       let nb,pos = get_value s pos last in
       let empty,pos = get_value s pos last in
       let max,pos = get_value s pos last in
       Hashtable (l,nb,empty,max),pos
    |10 ->
       let l,pos = get_list16 get_printf s (pos+1) last in
       Log l, pos
    |_ -> assert false


let get_declare s pos last =
  if pos > last-3 then raise IncompleteMessage;
  let tag,pos = get_int16 s pos in
  let kind,pos = get_kind s pos in
  let name,pos = get_string31 s pos last in
  tag,kind,name,pos

  
let get_send s pos last =
  if pos > last-3 then raise IncompleteMessage;
  let tag,pos = get_int16 s pos in
  let value,pos = get_value s pos last in
  tag,value,pos


let get_bind s pos last = 
  get_list16 safe_get_int16 s pos last

  
let decode_one s pos last =
  if pos > last-1 then raise IncompleteMessage;
  let typ_msg = get_uint8 s pos in
  match typ_msg with
    |0 -> let tag,kind,n,pos = get_declare s (pos+1) last in
       Declare (tag,kind,n), pos
    |1 -> let tag,v,pos = get_send s (pos+1) last in
       Send (tag,v), pos
    |2 -> let l,pos = get_bind s (pos+1) last in
       Bind l, pos
    |_ -> dump "get_msg" s pos last; assert false

      (*

let decode s first last =
  let rec loop acc i =
    try
      let m, nexti = get_msg s i last in
      loop (m :: acc) nexti
    with IncompleteMessage ->
      List.rev acc, i
  in
  loop [] first
    *)


(*
Local Variables: 
compile-command: "unset LANG; make -C .."
End: 
*)

