close_tag build "";
LOG ( __ "parsing" 2 "%s\n" "Finished parsing");
LOG ( __ "indexing" 2 "%s\n" "Starting index construction");
- let r = close_document build in
+ let r = close_document build
+ in
LOG ( __ "indexing" 2 "%s\n" "Finished index construction");
r
in
let in_chan = open_in file in
let buffer = String.create 4096 in
let parser_, finalizer = create_parser () in
- let () =
+ let parse () =
try
while true do
let read = input in_chan buffer 0 4096 in
| End_of_file -> close_in in_chan
| e -> raise e
in
- finalizer ()
+ Utils.time ~msg:"Parsing XML file" parse ();
+ Utils.time ~msg:"Creating tree and text-collection index" finalizer ()
end
LOG ( __ "indexing" 2 "%s\n" "Initializing tag structure");
let _ = Tag.init (mk_tag_ops t) in
LOG ( __ "indexing" 2 "%s\n" "Starting tag table construction");
- let f, n, c, d = time collect_labels t ~msg:"Building tag relationship table" in
+ let f, n, c, d = Utils.time ~msg:"Building tag relationship table" collect_labels t in
let c = Array.map TagS.to_ptset c in
let n = Array.map TagS.to_ptset n in
let f = Array.map TagS.to_ptset f in
in
loop 1
;;
+
+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