(**************************************************************************)
(*                                                                        *)
(*  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 Protocol
open Timemap

type status = St_active | St_killed | St_collected

type tag = {
  id:Protocol.tag;
  kind:kind; 
  name:string;
  tmap : value Timemap.t;
  mutable value : float*value;
  tmap_st : status Timemap.t;
  mutable status: float*status;
}


let tags = Hashtbl.create 17
let bind_table = Hashtbl.create 17

let point_table = Hashtbl.create 17
let time_table = Hashtbl.create 17
let tag_count_table = Hashtbl.create 17
let tag_max_count_table = Hashtbl.create 17 
let tag_size_table = Hashtbl.create 17
let tag_max_size_table = Hashtbl.create 17 
let int_table = Hashtbl.create 17 
let float_table = Hashtbl.create 17
let string_table = Hashtbl.create 17
let bool_table = Hashtbl.create 17
let tree_table = Hashtbl.create 17
let hash_table = Hashtbl.create 17

let time = ref 0.
let record_window = ref 60.
let offset = ref 0.
let log_size = ref 200

let set_record_window t = record_window := t
let get_record_window () = !record_window
let get_current_time () = !time

let set_observe_time t =
  if t > !time then invalid_arg "set_observer_time";
  offset := !time -. t;
  if !offset > !record_window then offset := !record_window

let get_observe_time () = !time -. !offset

let get_offset () = !offset

let set_offset t = 
  if ((!time -. t) < Timemap.get_min ()) 
  then offset := !time -. Timemap.get_min ()
  else offset := t
  

let get_log_size () = !log_size

let set_log_size i = log_size := i

let max_heap_size = create No_value

let heap_size_tag = 
  {id=0 ; kind=Special ; name="heap_size" ; tmap = create No_value; 
   value = (0.,No_value) ; tmap_st = create St_active ; status = (0.,St_active)}

let heap_alive_tag = 
  {id=1 ; kind=Special ; name="heap_alive" ; tmap = create No_value; 
   value = (0.,No_value) ; tmap_st = create St_active ; status = (0.,St_active)}

let log_tag =
  {id=3; kind=Klog ; name="log" ; tmap = create No_value;
   value = (0.,No_value) ; tmap_st = create St_active ; status = (0.,St_active)}


let () = 
  Hashtbl.replace tags 0 heap_size_tag;
  Hashtbl.replace tags 1 heap_alive_tag

let clean_up () = 
  let diff = max 0. (!time -. !record_window) in
  Hashtbl.iter (fun _ t -> Timemap.remove_before t.tmap diff; Timemap.remove_before t.tmap_st diff ) tags


let add_tag id kind name = 
  if not (Hashtbl.mem tags id) then 
    begin
      let tag = {id=id;kind=kind;name=name;tmap = create No_value; value= (0.,No_value); 
		 tmap_st = create St_active; status = (0.,St_active)} in
      match kind with 
	| Point -> 
            Hashtbl.replace tags id tag; Hashtbl.replace point_table id tag
	| Tag_size -> 
            Hashtbl.replace tags id tag; 
            Hashtbl.replace tag_size_table id tag; Hashtbl.replace tag_max_size_table id tag.tmap
	| Tag_count -> 
            Hashtbl.replace tags id tag;
            Hashtbl.replace tag_count_table id tag; Hashtbl.replace tag_max_count_table id tag.tmap
	| Time -> 
            Hashtbl.replace tags id tag; Hashtbl.replace time_table id tag
	| Value_bool -> 
            Hashtbl.replace tags id tag; Hashtbl.replace bool_table id tag
	| Value_float -> 
            Hashtbl.replace tags id tag; Hashtbl.replace float_table id tag
	| Value_int -> 
            Hashtbl.replace tags id tag; Hashtbl.replace int_table id tag
	| Value_string -> 
            Hashtbl.replace tags id tag; Hashtbl.replace string_table id tag
	| Ktree -> 
            Hashtbl.replace tags id tag; Hashtbl.replace tree_table id tag
	| Hash -> 
            Hashtbl.replace tags id tag; Hashtbl.replace hash_table id tag
        | Klog ->
            Hashtbl.replace tags id log_tag
	| Special -> 
            match id with
              | 0 -> ()
              | 1 -> ()
              | 2 -> Hashtbl.replace tags id tag
              | _ -> assert false
    end



let get_log () = 
  Timemap.find log_tag.tmap (!time -. !offset)


let replace_log value =
  let remafter diff l = 
    let rec fct cpt acc l = 
      if cpt = 0 then List.rev acc
      else
        match l with
          |e::l -> fct (cpt-1) (e::acc) l
          |[] -> assert false
           
    in
    fct diff [] l
  in
  let _,v = Timemap.find log_tag.tmap !time in
  match value,v with
    |Log l,Log l' -> 
       let len_l = List.length l in
       let len_l'= List.length l' in
       let diff =  len_l + len_l' - !log_size in
       if diff > 0 then
	 if len_l >= !log_size then
           let l = remafter !log_size l in
           Timemap.add log_tag.tmap !time (Log l)
	 else 
           let l' = remafter (!log_size - len_l) l' in
	   Timemap.add log_tag.tmap !time (Log (l@l'))
       else Timemap.add log_tag.tmap !time (Log (l@l'))
    |Log l,No_value -> Timemap.add log_tag.tmap !time (Log l)
    |_ -> assert false


     

let replace tag value =
    let old_value = tag.tmap in
    let t,v = Timemap.find old_value !time in
    match value,v with
      |Int i, Int i' ->  if i <> i' then Timemap.add tag.tmap !time value
      |Float f , Float f' -> if f <> f' then Timemap.add tag.tmap !time value
      |Int64 i, Int64 i' -> if i <> i' then Timemap.add tag.tmap !time value
      |Bool b, Bool b' -> if b <> b' then Timemap.add tag.tmap !time value
      |String s, String s' -> if s <> s' then Timemap.add tag.tmap !time value
      |Collected , _ -> Timemap.add tag.tmap !time value
      |Tree t,_ -> Timemap.add tag.tmap !time value
      |Hashtable (v1,v2,v3,v4),Hashtable (v1',v2',v3',v4') ->
	 if v1<>v1' && v2<>v2' && v3<>v3' && v4<>v4' then
           Timemap.add tag.tmap !time value
      |Log _ , _ -> replace_log value
      |_ , No_value -> Timemap.add tag.tmap !time value
      |_ -> assert false
         
         
let change_value id value = 
  let tag = 
    try
      Hashtbl.find tags id 
    with Not_found -> assert false
  in
  begin
    match value with
      | Killed -> Timemap.add tag.tmap_st !time St_killed
      | Collected -> Timemap.add tag.tmap_st !time St_collected; replace tag value
      | _ -> replace tag value
  end;
  
  begin
    match id, tag.kind  with
      | 0,_ -> (* max size for heap *)
	  begin
	    let _,value2 = Timemap.find max_heap_size !time in
	    match value,value2 with
	      |Int64 i, Int64 i2 -> 
	       if i > i2 
	       then Timemap.add max_heap_size !time value 
	      | Int64 i, No_value -> Timemap.add max_heap_size !time value
	      |_ , _ -> ()
	  end
	    
	    
      | 2,_ -> (* execution time *)
	  begin
	    match value with
	      |Float f -> time := f
	      |_ -> ()
	  end
	    
      | _, Tag_count ->  (* max for tag count *)
	  if (Hashtbl.mem tag_count_table id)
	  then begin
	    let _,value2 = 
	      try
		Timemap.find (Hashtbl.find tag_max_count_table id) !time 
	      with Not_found -> assert false
	    in
	    match value,value2 with 
	      |Int i, Int i2 ->
		 if i > i2
		 then 
		   Timemap.add (Hashtbl.find tag_max_count_table id) !time value
	      |Int64 i, Int64 i2 ->
		 if i > i2
		 then 
		   Timemap.add (Hashtbl.find tag_max_count_table id) !time value
	      |Int i , No_value -> Timemap.add (Hashtbl.find tag_max_count_table id) !time value
	      |Int64 i , No_value -> Timemap.add (Hashtbl.find tag_max_count_table id) !time value
	      |_ -> ()
	  end

      | _, Tag_size -> (* max for tag size *)
	  if (Hashtbl.mem tag_size_table id)
	  then begin
	    let _,value2 = 
	      try
		Timemap.find (Hashtbl.find tag_max_size_table id) !time 
	      with Not_found -> assert false
	      in
	    match value,value2 with 
	      |Int64 i, Int64 i2 ->
		 if i > i2
		 then
		   Timemap.add (Hashtbl.find tag_max_size_table id) !time value
	      |Int64 i, No_value ->  Timemap.add (Hashtbl.find tag_max_size_table id) !time value
	      |_ -> ()       
	  end

      | _ -> ()
  end	       
  

	
	
let interp = function
  |Declare (t,k,n) -> add_tag t k n
  |Send (t,v) -> change_value t v
  |Bind l -> List.iter (fun e -> Hashtbl.add bind_table e l) l


let list_of_table t =
  Hashtbl.fold
    (fun _ tag l -> 
       tag.value <- (let ti,v = Timemap.find tag.tmap (!time -. !offset) in (ti,v));
       tag.status <- (let ti,v = Timemap.find tag.tmap_st (!time -. !offset) in (ti,v));
       tag::l)
    t []


let value_of_tag t table =
  try
    Timemap.find (Hashtbl.find table t).tmap (!time -. !offset) 
  with Not_found ->
    assert false


let get_tag id = 
  try
    let tag = (Hashtbl.find tags id) in
    tag.value <- (let t,v = Timemap.find tag.tmap (!time -. !offset) in (t,v));
    tag.status <- (let t,v = Timemap.find tag.tmap_st (!time -. !offset) in (t,v));
    tag
  with Not_found ->
    assert false


let get_point_list () = list_of_table point_table


let get_time_list () = list_of_table time_table


let get_tag_count_list () = list_of_table tag_count_table


let get_tag_size_list () = list_of_table tag_size_table


let get_value_int_list () = list_of_table int_table


let get_value_float_list () = list_of_table float_table


let get_value_string_list () = list_of_table string_table


let get_value_bool_list () = list_of_table bool_table


let get_tree_list () = list_of_table tree_table


let get_hash_list () = list_of_table hash_table


let get_bindings t =
  try
    Hashtbl.find bind_table t 
  with Not_found -> []


let get_tag_size t =
  value_of_tag t tag_size_table
  

let get_tag_count t =
  value_of_tag t tag_count_table


let get_point t =
  value_of_tag t point_table


let get_time t =
  value_of_tag t time_table


let get_value_int t = 
  value_of_tag t int_table
  

let get_value_float t = 
  value_of_tag t float_table
  

let get_value_string t = 
  value_of_tag t string_table


let get_value_bool t = 
  value_of_tag t bool_table
    

let get_heap_total_size () = 
  Timemap.find heap_size_tag.tmap (!time -. !offset) 


let get_heap_alive_size () =
  Timemap.find heap_alive_tag.tmap (!time -. !offset) 


let get_heap_max_size () =
  Timemap.find max_heap_size (!time -. !offset) 


let get_tag_max_count id =
  try
    Timemap.find  (Hashtbl.find tag_max_count_table id) (!time -. !offset) 
  with Not_found -> assert false


let get_tag_max_size id =
    try
      Timemap.find (Hashtbl.find tag_max_size_table id) (!time -. !offset) 
    with Not_found -> assert false


let get_percent_time id = 
  let t = get_observe_time () in
  let time',t' = get_time id in
  match t,t' with
    |f, Float f' ->  
       if f<>0. then 
	 (time',Float (f' *. 100. /. f))
       else (time',Float 0.)
    |_,Killed -> (time',Killed)
    |_,_ -> (time',No_value  )


let get_tag_percent_size id = 
  let _,s = get_heap_total_size () in
  let t',s' = get_tag_size id in
  match s,s' with
    |Int64 i, Int64 i2 -> 
       let i = Int64.to_float i in
       let i2 = Int64.to_float i2 in
       if i <> 0. then
	 (t',Float (i2 *. 100. /. i))
       else (t',Float 0.)
    |_,Killed -> (t',Killed)
    | _, _ -> (t',No_value)


let get_tree t = 
  value_of_tag t tree_table


let get_hash t =
  value_of_tag t hash_table


let get_hash_percent_filled id =
  let t,v = get_hash id in
  match v with
    |Hashtable (Int l,_,Int e,_) ->
       if l = 0 then (t, Float 0.)
       else
	 let lf = float l in
	 let ef = float e in
	 (t, Float ((lf -. ef ) /. lf *. 100.))
    |Hashtable (Int64 l,_,Int64 e,_) ->
       if l = 0L then (t, Float 0.)
       else
	 let lf = Int64.to_float l in
	 let ef = Int64.to_float e in
	 (t, Float ((lf -. ef ) /. lf *. 100.))
    |No_value -> t,No_value
    |_ -> assert false


let get_hash_mean id = 
  let t,v = get_hash id in
  match v with
    |Hashtable (Int l,Int n,Int e,Int _) ->
       if l = e then (t , Float 0.)
       else 
	 let lf = float l in
	 let nf = float n in
	 let ef = float e in
	 (t, Float (nf /. (lf -. ef)) )
    |Hashtable (Int64 l,Int64 n,Int64 e,Int64 _) ->
       if l = e then (t , Float 0.)
       else 
	 let lf = Int64.to_float l in
	 let nf = Int64.to_float n in
	 let ef = Int64.to_float e in
	 (t, Float (nf /. (lf -. ef)) )
    |No_value -> (t, No_value)
    |_ -> assert false


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