let time f a msg = let t0 = Unix.gettimeofday () in let r = f a in let t1 = Unix.gettimeofday () in Printf.printf "Timing %s: %f ms\n" msg ((t1 -. t0) *. 1000.); r type pointers type allocation_order = PREORDER | INORDER | POSTORDER external build_pointers : Tree.t -> allocation_order -> pointers = "caml_build_pointers" external iter_pointers : pointers -> int = "caml_iter_pointers" external free_pointers : pointers -> unit = "caml_free_pointers" let string_of_alloc = function PREORDER -> "preorder" | INORDER -> "inorder" | POSTORDER -> "postorder" let test_pointers alloc v = let size = Tree.subtree_size v Tree.root in if ((size * (Sys.word_size/8)*2) / (1024*1024)) >= 2800 then Printf.printf "Not enough memory to allocate pointer with %i nodes\n%!" size else begin let msg1 = Printf.sprintf "pointer structure %s allocation" (string_of_alloc alloc) in let pointers = time (build_pointers v) alloc msg1 in let i = time (iter_pointers) pointers "pointer structure full traversal" in Printf.printf "Traversed %i nodes\n" i; time (free_pointers) pointers "pointer structure deallocation" end ;; let test_iterative v = let i = time (Tree.benchmark_iter) v "iterative traversal (on sxsi)" in Printf.printf "Traversed %i nodes\n%!" i let test_full_traversal v = let i = time (Tree.benchmark_fcns) v "recursive traversal (on sxsi)" in Printf.printf "Traversed %i nodes\n%!" i let test_full_elements v = let i = time (Tree.benchmark_fene) v "recursive traversal of element nodes (on sxsi)" in Printf.printf "Traversed %i nodes\n%!" i let test_tag_jump v t = let msg = Printf.sprintf "jumping to tag <%s> (on sxsi)" (Tag.to_string t) in let i = time (Tree.benchmark_jump v) t msg in Printf.printf "Traversed %i nodes\n%!" i module Options = struct open Arg let input_file = ref "" let save_file = ref "" let run_iterative = ref false let run_full_sxsi = ref false let run_elements = ref false let run_pointers = ref [] let run_jump_tag = ref "" let add_pointer t = let tag = match t with | "preorder" -> PREORDER | "inorder" -> INORDER | "postorder" -> POSTORDER | _ -> raise (Bad (t)) in if not (List.mem tag !run_pointers) then run_pointers := tag :: !run_pointers let spec = align [ "-s", Set_string save_file, " saves the index in file output.srx"; "-i", Set run_iterative, " runs the iterative full traversal (on sxsi)"; "-f", Set run_full_sxsi, " runs the recursive full traversal (on sxsi)"; "-e", Set run_elements, " simulates //* on sxsi"; "-p", Symbol ([ "preorder"; "inorder"; "postorder" ], add_pointer), "runs a full traveral over pointers with given allocation scheme"; "-t", Set_string run_jump_tag, " simulates //tag on sxsi" ] let usage_msg = Printf.sprintf "%s [options] " Sys.argv.(0) let parse () = parse spec (fun s -> input_file := s) usage_msg let usage () = usage spec usage_msg end let fail msg = Printf.eprintf "error: %s%!" msg; Options.usage (); exit 1 let line () = Printf.printf "\n%!" let main () = Options.parse (); if !Options.input_file = "" then fail "missing input file"; let ifile = !Options.input_file in let doc = if Filename.check_suffix ifile ".srx" then Tree.load ifile else Tree.parse_xml_uri ifile in if !Options.save_file <> "" then begin Printf.printf "Saving index to %s ... %!" !Options.save_file; Tree.save doc !Options.save_file; Printf.printf "done\n%!" end; Tag.init (Tree.tag_pool doc); line (); if !Options.run_iterative then (test_iterative doc; line ()); if !Options.run_full_sxsi then (test_full_traversal doc; line ()); if !Options.run_elements then (test_full_elements doc; line ()); if !Options.run_jump_tag <> "" then (test_tag_jump doc (Tag.tag !Options.run_jump_tag); line ()); if !Options.run_pointers <> [] then List.iter (fun s -> test_pointers s doc; line ()) !Options.run_pointers; exit 0 ;; let _ = let () = Printexc.record_backtrace true in try main () with _ -> let msg = Printexc.get_backtrace () in Printf.eprintf "%s\n%!" msg; exit 3