X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=src%2Futils.ml;h=38329987ca4a36bb61eca4c43e0d4a27ed6477b1;hb=cb728132e1c5cb0a171ee09e9b3ced16da08f796;hp=c5547aae761c24b6fe9737667e8aaf623642eaa5;hpb=63db110485e97e189313abd1a6ce1bedf941d76d;p=SXSI%2Fxpathcomp.git

diff --git a/src/utils.ml b/src/utils.ml
index c5547aa..3832998 100644
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -22,3 +22,118 @@ struct
     loop 0
 end
 ;;
+
+module System =
+struct
+  let status () =
+    let pid = Unix.getpid() in
+    let cin = open_in (Printf.sprintf "/proc/%i/status" pid) in
+    let h = Hashtbl.create 17 in
+    try
+      while true do
+        let s = input_line cin in
+        Scanf.sscanf s "%s@: %s@\n" (fun k v ->
+          Hashtbl.replace h k v)
+      done;
+      (* never reached *)
+      h
+    with
+      End_of_file -> begin
+        close_in cin;
+        h
+      end
+  let get_status s = Hashtbl.find (status()) s
+
+  let pr_mem_status fmt h =
+    Format.fprintf fmt "[";
+    List.iter (fun k ->
+      let v = Hashtbl.find h k in
+      Format.fprintf fmt "%s: %s " k v
+    ) [ "VmStk"; "VmRSS"; "VmPeak" ];
+    Format.fprintf fmt "]"
+
+end
+
+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