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       if len <= 1 then
  88       Logger.verbose fmt
  89         "@\n\
  90 | Time        :   %fms@\n\
  91 | Memory before:  %a@\n\
  92 | Memory after:   %a@\n]@]@]@\n"
  93         tmin
  94         System.pr_mem_status memo
  95         System.pr_mem_status memn
  96       else
  97       Logger.verbose fmt
  98         "@\n\
  99 | Number of runs: %i@\n\
 100 | Average time:   %fms@\n\
 101 | Minimum time:   %fms@\n\
 102 | Maximum time:   %fms@\n\
 103 | Memory before:  %a@\n\
 104 | Memory after:   %a@\n]@]@]@\n"
 105         len
 106         (ttotal /. (float_of_int len))
 107         tmin
 108         tmax
 109         System.pr_mem_status memo
 110         System.pr_mem_status memn
 111
 112
 113 let time f ?(count=1) ?(msg="") x =
 114   if not !Config.verbose then f x
 115   else
 116   let rec loop i =
 117     let oldmem = System.status () in
 118     let t1 = Unix.gettimeofday () in
 119     set_timing msg ((t1, oldmem, oldmem)::(get_timing msg));
 120     let r = f x in
 121     let t2 = Unix.gettimeofday () in
 122     let newmem = System.status () in
 123     let t1, oldmem, l =
 124       match get_timing msg with
 125         (a, b, _) :: l -> a,b,l
 126       | _ -> assert false
 127     in
 128     let t = (1000. *. (t2 -. t1)) in
 129     set_timing msg ((t, oldmem, newmem)::l);
 130     if i >= count then r
 131     else loop (i+1)
 132   in
 133   Queue.push msg _t_queue;
 134   let r = loop 1 in
 135   begin
 136     if (Queue.peek _t_queue) = msg then
 137     let pr_stack = Queue.fold (fun a e -> e::a)  [] _t_queue in
 138     Queue.clear _t_queue;
 139     List.iter (fun msg' ->
 140       let sub =
 141         if msg' <> msg then "> " else "= "
 142       in
 143       display_result Format.err_formatter msg' sub (get_timing msg')) pr_stack;
 144   end;
 145   r
 146
 147
 148   end
 149 let time = Timing.time