From 7e27afe6fa006ad355237ccc0695c6493ea57929 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= <kn@lri.fr>
Date: Sun, 21 Oct 2012 12:10:34 +0200
Subject: [PATCH] Make the time function re-entrant.

---
 src/main.ml  |  4 +--
 src/tree.ml  | 10 ++++---
 src/utils.ml | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 92 insertions(+), 6 deletions(-)

diff --git a/src/main.ml b/src/main.ml
index 00d5ab9..909a0b8 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -88,7 +88,7 @@ let _ =
       if Filename.check_suffix !Config.input_file ".srx"
       then
 	Utils.time
-	  ~msg:"Loading file"
+	  ~msg:"Loading Index file"
 	  (Tree.load
 	     ~sample:!Config.sample_factor
 	     ~load_text:(not !Config.disable_text_collection))
@@ -96,7 +96,7 @@ let _ =
       else
 	let v =
 	  Utils.time
-	    ~msg:"Parsing document"
+	    ~msg:"Loading XML file"
 	    (Tree.parse_xml_uri)
 	    !Config.input_file
 	in
diff --git a/src/tree.ml b/src/tree.ml
index 0c62ec7..b7b8566 100644
--- a/src/tree.ml
+++ b/src/tree.ml
@@ -125,7 +125,8 @@ struct
       close_tag build "";
       LOG ( __ "parsing" 2 "%s\n" "Finished parsing");
       LOG ( __ "indexing" 2 "%s\n" "Starting index construction");
-      let r = close_document build in
+      let r = close_document build
+      in
       LOG ( __ "indexing" 2 "%s\n" "Finished index construction");
       r
     in
@@ -146,7 +147,7 @@ struct
     let in_chan = open_in file in
     let buffer = String.create 4096 in
     let parser_, finalizer = create_parser () in
-    let () =
+    let parse () =
       try
 	while true do
 	  let read = input in_chan buffer 0 4096 in
@@ -158,7 +159,8 @@ struct
       | End_of_file -> close_in in_chan
       | e -> raise e
     in
-    finalizer ()
+    Utils.time ~msg:"Parsing XML file" parse ();
+    Utils.time ~msg:"Creating tree and text-collection index" finalizer ()
 
 end
 
@@ -543,7 +545,7 @@ let node_of_t t  =
   LOG ( __ "indexing" 2 "%s\n" "Initializing tag structure");
   let _ = Tag.init (mk_tag_ops t) in
   LOG ( __ "indexing" 2 "%s\n" "Starting tag table construction");
-  let f, n, c, d = time collect_labels t ~msg:"Building tag relationship table" in
+  let f, n, c, d = Utils.time ~msg:"Building tag relationship table" collect_labels t in
   let c = Array.map TagS.to_ptset c in
   let n = Array.map TagS.to_ptset n in
   let f = Array.map TagS.to_ptset f in
diff --git a/src/utils.ml b/src/utils.ml
index 8cab636..23f3e91 100644
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -78,3 +78,87 @@ let time f ?(count=1) ?(msg="") x =
   in
   loop 1
 ;;
+
+module Timing =
+  struct
+    let _timings = Hashtbl.create 43
+    let _t_queue = Queue.create ()
+
+    let get_timing s =
+      try
+        Hashtbl.find _timings s
+      with
+        Not_found -> []
+
+    let set_timing s v =
+      Hashtbl.replace _timings s v
+
+
+    let display_result fmt msg sub l =
+      let h = Hashtbl.create 0 in
+      let tmin, tmax, ttotal, len, memo, memn =
+        List.fold_left (fun
+        (atmin, atmax, attotal, alen, _, _)
+        (t, om, nm) ->
+          (min t atmin,
+           max atmax t,
+           attotal +. t,
+           alen + 1,
+           om, nm))
+          (infinity, 0., 0., 0, h, h) l
+      in
+      Logger.verbose fmt "@[%s%s: [" sub msg;
+      Format.pp_open_vbox fmt (2 + String.length msg + String.length sub);
+      Logger.verbose fmt
+        "@\n\
+| Number of runs: %i@\n\
+| Average time:   %fms@\n\
+| Minimum time:   %fms@\n\
+| Maximum time:   %fms@\n\
+| Memory before:  %a@\n\
+| Memory after:   %a@\n]@]@]@\n"
+        len
+        (ttotal /. (float_of_int len))
+        tmin
+        tmax
+        System.pr_mem_status memo
+        System.pr_mem_status memn
+
+
+let time f ?(count=1) ?(msg="") x =
+  if not !Config.verbose then f x
+  else
+  let rec loop i =
+    let oldmem = System.status () in
+    let t1 = Unix.gettimeofday () in
+    set_timing msg ((t1, oldmem, oldmem)::(get_timing msg));
+    let r = f x in
+    let t2 = Unix.gettimeofday () in
+    let newmem = System.status () in
+    let t1, oldmem, l =
+      match get_timing msg with
+        (a, b, _) :: l -> a,b,l
+      | _ -> assert false
+    in
+    let t = (1000. *. (t2 -. t1)) in
+    set_timing msg ((t, oldmem, newmem)::l);
+    if i >= count then r
+    else loop (i+1)
+  in
+  Queue.push msg _t_queue;
+  let r = loop 1 in
+  begin
+    if (Queue.peek _t_queue) = msg then
+    let pr_stack = Queue.fold (fun a e -> e::a)  [] _t_queue in
+    Queue.clear _t_queue;
+    List.iter (fun msg' ->
+      let sub =
+        if msg' <> msg then "(sub-timing) " else ""
+      in
+      display_result Format.err_formatter msg' sub (get_timing msg')) pr_stack;
+  end;
+  r
+
+
+  end
+let time = Timing.time
-- 
2.17.1