stats.ml 1.86 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
type verbosity = Quiet | Summary | Details
let verbosity = ref Quiet
let set_verbosity = (:=) verbosity

let todo = ref []

let register level f = todo := (level,f) :: !todo

let dump ppf =
  List.iter (function
	       | (level,f) when level <= !verbosity -> f ppf
	       | _ -> ()) !todo

module Timer = struct
  type t = {
    name: string;
    mutable count : int;
    mutable total : float;
    mutable last  : float;
    mutable is_in : bool;
  }

  let print ppf c =
24
    Format.fprintf ppf "Timer %s. Total time: %f. Count: %i@."
25
26
27
28
29
30
31
32
33
34
35
36
37
      c.name c.total c.count
      
  let create s = 
    let c = { name = s; count = 0; total = 0.; last = 0.; is_in = false } in
    register Summary (fun ppf -> print ppf c);
    c
      
  let start c =
    assert(not c.is_in);
    c.is_in <- true;
    c.last <- Unix.gettimeofday();
    c.count <- c.count + 1
      
38
  let stop c x =
39
40
    assert(c.is_in);
    c.is_in <- false;
41
    c.total <- c.total +. (Unix.gettimeofday() -. c.last);
42
43
44
45
46
47
48
49
50
51
    x
end

module Counter = struct
  type t = {
    name: string;
    mutable count : int;
  }

  let print ppf c =
52
    Format.fprintf ppf "Counter %s: %i@."
53
54
55
56
57
58
59
60
61
      c.name c.count
      
  let create s = 
    let c = { name = s; count = 0 } in
    register Summary (fun ppf -> print ppf c);
    c
      
  let incr c =
    c.count <- c.count + 1
62
63
64

  let add c n =
    c.count <- c.count + n
65
end
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96


module InOut = struct
  let h = Hashtbl.create 17

  let enter s =
    let i = try Hashtbl.find h s with Not_found ->
      let r = ref 0 in
      Hashtbl.add h s r;
      r in
    incr i;
    Printf.printf "+%s[%i] " s !i;
    flush stdout

  let leave s =
    let i = try Hashtbl.find h s with Not_found -> assert false in
    decr i;
    Printf.printf "-%s[%i] " s !i;
    flush stdout

  let wrap s f x =
    enter s;
    try
      let r = f x in
      leave s;
      r
    with exn ->
      leave s;
      raise exn
    
end