Remove non-reentrant timing function.
[SXSI/xpathcomp.git] / src / utils.ml
1 module String =
2 struct
3   include String
4
5   let explode s sep =
6     let len = length s in
7     let buff = Buffer.create 40 in
8     let rec loop i =
9       if i >= len then
10         [ Buffer.contents buff ]
11       else
12         let c = s.[i] in
13         if c == sep then
14           let ss = Buffer.contents buff in
15           Buffer.clear buff;
16           ss :: loop (i+1)
17         else begin
18           Buffer.add_char buff c;
19           loop (i+1);
20         end
21     in
22     loop 0
23 end
24 ;;
25
26 module System =
27 struct
28   let status () =
29     let pid = Unix.getpid() in
30     let cin = open_in (Printf.sprintf "/proc/%i/status" pid) in
31     let h = Hashtbl.create 17 in
32     try
33       while true do
34         let s = input_line cin in
35         Scanf.sscanf s "%s@: %s@\n" (fun k v ->
36           Hashtbl.replace h k v)
37       done;
38       (* never reached *)
39       h
40     with
41       End_of_file -> begin
42         close_in cin;
43         h
44       end
45   let get_status s = Hashtbl.find (status()) s
46
47   let pr_mem_status fmt h =
48     Format.fprintf fmt "[";
49     List.iter (fun k ->
50       let v = Hashtbl.find h k in
51       Format.fprintf fmt "%s: %s " k v
52     ) [ "VmStk"; "VmRSS"; "VmPeak" ];
53     Format.fprintf fmt "]"
54
55 end
56
57 module Timing =
58   struct
59     let _timings = Hashtbl.create 43
60     let _t_queue = Queue.create ()
61
62     let get_timing s =
63       try
64         Hashtbl.find _timings s
65       with
66         Not_found -> []
67
68     let set_timing s v =
69       Hashtbl.replace _timings s v
70
71
72     let display_result fmt msg sub l =
73       let h = Hashtbl.create 0 in
74       let tmin, tmax, ttotal, len, memo, memn =
75         List.fold_left (fun
76         (atmin, atmax, attotal, alen, _, _)
77         (t, om, nm) ->
78           (min t atmin,
79            max atmax t,
80            attotal +. t,
81            alen + 1,
82            om, nm))
83           (infinity, 0., 0., 0, h, h) l
84       in
85       Logger.verbose fmt "@[%s%s: [" sub msg;
86       Format.pp_open_vbox fmt (2 + String.length msg + String.length sub);
87       Logger.verbose fmt
88         "@\n\
89 | Number of runs: %i@\n\
90 | Average time:   %fms@\n\
91 | Minimum time:   %fms@\n\
92 | Maximum time:   %fms@\n\
93 | Memory before:  %a@\n\
94 | Memory after:   %a@\n]@]@]@\n"
95         len
96         (ttotal /. (float_of_int len))
97         tmin
98         tmax
99         System.pr_mem_status memo
100         System.pr_mem_status memn
101
102
103 let time f ?(count=1) ?(msg="") x =
104   if not !Config.verbose then f x
105   else
106   let rec loop i =
107     let oldmem = System.status () in
108     let t1 = Unix.gettimeofday () in
109     set_timing msg ((t1, oldmem, oldmem)::(get_timing msg));
110     let r = f x in
111     let t2 = Unix.gettimeofday () in
112     let newmem = System.status () in
113     let t1, oldmem, l =
114       match get_timing msg with
115         (a, b, _) :: l -> a,b,l
116       | _ -> assert false
117     in
118     let t = (1000. *. (t2 -. t1)) in
119     set_timing msg ((t, oldmem, newmem)::l);
120     if i >= count then r
121     else loop (i+1)
122   in
123   Queue.push msg _t_queue;
124   let r = loop 1 in
125   begin
126     if (Queue.peek _t_queue) = msg then
127     let pr_stack = Queue.fold (fun a e -> e::a)  [] _t_queue in
128     Queue.clear _t_queue;
129     List.iter (fun msg' ->
130       let sub =
131         if msg' <> msg then "(sub-timing) " else ""
132       in
133       display_result Format.err_formatter msg' sub (get_timing msg')) pr_stack;
134   end;
135   r
136
137
138   end
139 let time = Timing.time