Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 67 lines (58 sloc) 2.301 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 type t = { start : unit -> unit ; restart : unit -> unit ; stop : unit -> unit ; read : unit -> float ; reset : unit -> unit }
21 let make () = (* start , stop , read , reset *)
22 let c = ref 0. in (* date of the last time you started it *)
23 let t = ref 0. in (* cumulated time *)
24 let stop = ref true in
25 {start = (fun () -> if !stop then (stop := false ; c := Unix.gettimeofday()) else ());
26 stop = (fun () -> if !stop then () else (stop := true ; t := !t +. ((Unix.gettimeofday()) -. !c)));
27 read = (fun () -> if !stop then !t else !t +. (Unix.gettimeofday()) -. !c);
28 reset = (fun () -> stop := true; t := 0.);
29 restart = (fun () -> stop := false; t := 0. ; c := Unix.gettimeofday ())}
30 let start t = t.start ()
31 let restart t = t.restart ()
32 let stop t = t.stop ()
33 let read t = t.read ()
34 let reset t = t.reset ()
35 let print t msg =
36 let f = t.read () in
37 Printf.printf "%s: %.2fs\n%!" msg f;
38 t.restart ()
39
40 let measure f g =
41 let t0=Unix.gettimeofday() in
42 let res= f() in
43 let t1=Unix.gettimeofday() in
44 g (t1-.t0);
45 res
46
47 let measure_and_show prefix f =
48 measure f (fun duration -> Printf.eprintf "%s: %fs\n%!" prefix duration)
49
50 let bound timeout f when_timeout =
51 Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> failwith "timeout"));
52 ignore (Unix.alarm timeout);
53 try
54 let r = f() in
55 ignore (Unix.alarm 0);
56 r
57 with
58 | Failure "timeout" -> when_timeout()
59 | Stack_overflow | Out_of_memory ->
60 (* we must clear the still-pending alarm *)
61 ignore (Unix.alarm 0);
62 when_timeout()
63 | e ->
64 (* we must clear the still-pending alarm *)
65 ignore (Unix.alarm 0);
66 raise e
Something went wrong with that request. Please try again.