src/tatoo.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                               TAToo                                 *)
   4 (*                                                                     *)
   5 (*                     Kim Nguyen, LRI UMR8623                         *)
   6 (*                   Université Paris-Sud & CNRS                       *)
   7 (*                                                                     *)
   8 (*  Copyright 2010-2012 Université Paris-Sud and Centre National de la *)
   9 (*  Recherche Scientifique. All rights reserved.  This file is         *)
  10 (*  distributed under the terms of the GNU Lesser General Public       *)
  11 (*  License, with the special exception on linking described in file   *)
  12 (*  ../LICENSE.                                                        *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 open Format
  17 let default_gc = Gc.get()
  18 let tuned_gc = { default_gc with
  19   Gc.minor_heap_size = 32*1024*1024;
  20   Gc.major_heap_increment = 8*1024*1024;
  21   Gc.max_overhead = 1000000;
  22   Gc.space_overhead = 100;
  23 }
  24
  25 let time f arg msg =
  26   let t1 = Unix.gettimeofday () in
  27   let r = f arg in
  28   let t2 = Unix.gettimeofday () in
  29   let time = (t2 -. t1) *. 1000. in
  30   Logger.msg `STATS "%s: %fms" msg time;
  31   r
  32
  33
  34 let compose_parallel run auto_list tree nodes () =
  35   match auto_list with
  36     [ auto ] -> [run auto tree nodes]
  37   | _ -> assert false
  38
  39 let compose_sequential run auto_list tree nodes () =
  40   [ List.fold_left (fun acc auto ->
  41     run auto tree acc) nodes auto_list ]
  42
  43
  44 let restart_parallel run auto_list tree nodes () =
  45   match auto_list with
  46     [ auto ] -> List.map snd (run auto tree nodes)
  47   | _ -> assert false
  48
  49 let restart_sequential run auto_list tree nodes () =
  50   List.map (fun auto -> run auto tree nodes) auto_list
  51
  52 let main () =
  53   let () = Options.parse () in
  54   let tree_model = List.assoc !Options.tree_model
  55       Options.supported_models
  56   in
  57   let module T = (val tree_model) in
  58   let module Runtime = Run.Make(T)
  59   in
  60
  61   let doc =
  62     let fd, close_fd = match !Options.input_file with
  63       None | Some "-" | Some "/dev/stdin" -> stdin, ignore
  64     | Some input ->
  65         let fd = open_in input in fd, fun () -> close_in fd
  66     in
  67     let d = time Runtime.Tree.load_xml_file fd "parsing xml document" in
  68     close_fd (); d
  69   in
  70   let () =
  71       Gc.full_major();
  72       Gc.compact();
  73       Gc.set (tuned_gc)
  74   in
  75   let () =
  76     let rec loop node = if node == Runtime.Tree.nil then () else
  77         let i = Runtime.Tree.preorder doc node in
  78         let () = loop (Runtime.Tree.first_child doc node) in
  79         loop (Runtime.Tree.next_sibling doc node)
  80     in
  81     time loop (Runtime.Tree.root doc) "calibrating full traversal"
  82   in
  83   let queries =
  84     time
  85       (fun l ->
  86         List.map (fun q ->
  87           Xpath.Parser.parse
  88             (Ulexing.from_utf8_string q)) l)
  89       !Options.queries
  90       "parsing XPath queries"
  91   in
  92   (* parallel, compose  ->     action
  93      true, true -> Ata.concat of all automata and single run
  94      true, false -> Ata.merge of all automata and single run
  95      false, true -> Eval first, then run on results then ...
  96      false, false -> Eval first on root, then second on root then ...
  97   *)
  98   let auto_list =
  99     time
 100       (fun l ->
 101         List.map (fun query -> Xpath.Compile.path query) l)
 102       queries
 103       "compiling XPath queries"
 104   in
 105   let auto_list =
 106     if !Options.parallel then
 107       match auto_list with
 108         fst :: rest ->
 109           let f =
 110             if !Options.compose then
 111               Ata.concat
 112             else
 113               Ata.merge
 114           in
 115           let big_auto = List.fold_left f fst rest in
 116           [big_auto]
 117       | _ -> assert false
 118
 119     else
 120       auto_list
 121   in
 122   let output =
 123     match !Options.output_file with
 124     | None | Some "-" | Some "/dev/stdout" -> stdout
 125     | Some f -> open_out f
 126   in
 127   if !Options.stats then begin
 128     List.iter (fun query ->
 129       Logger.msg `STATS "Query: %a " Xpath.Ast.print_path query) queries;
 130     List.iter (fun auto ->
 131       Logger.msg `STATS "@[Automaton: @\n%a@]" Ata.print auto) auto_list;
 132   end;
 133
 134   let result_list =
 135     let root = Runtime.ResultSet.create () in
 136     let () =  Runtime.ResultSet.add (Runtime.Tree.root doc) root in
 137     let f, msg =
 138       match !Options.parallel, !Options.compose with
 139         true, true ->
 140           compose_parallel Runtime.eval auto_list doc root, "parallel/compose"
 141       | true, false ->
 142           restart_parallel Runtime.full_eval auto_list doc root, "parallel/restart"
 143       | false, true ->
 144           compose_sequential Runtime.eval auto_list doc root , "sequential/compose"
 145       | false, false ->
 146           restart_sequential Runtime.eval auto_list doc root, "sequential/restart"
 147     in
 148     time f () ("evaluating query in " ^ msg ^ " mode")
 149   in
 150   let s = Runtime.stats () in
 151   Run.(
 152   Logger.msg `STATS
 153     "@[tree size: %d@\ntraversals: %d@\ntransition fetch cache miss ratio: %f@\ntransition eval cache miss ratio: %f@\nNumber of visited nodes per pass: %a@]"
 154     s.tree_size s.pass
 155     (float s.fetch_trans_cache_miss /. float s.fetch_trans_cache_access)
 156     (float s.eval_trans_cache_miss /. float s.eval_trans_cache_access)
 157     (let i = ref 0 in
 158      Pretty.print_list ~sep:"," (fun fmt n -> Format.fprintf fmt "%i: %i" !i n;incr i))
 159     s.nodes_per_run);
 160   time (fun () ->
 161     let count = ref 1 in
 162     List.iter (fun results ->
 163       output_string output "<xml_result num=\"";
 164       output_string output (string_of_int !count);
 165       output_string output "\" >\n";
 166       if !Options.count then begin
 167         output_string output (string_of_int (Runtime.ResultSet.length results));
 168         output_char output '\n';
 169       end else
 170         Runtime.ResultSet.iter (fun n ->
 171             Runtime.Tree.print_xml output doc n;
 172           output_char output '\n'
 173         ) results;
 174       output_string output "</xml_result>\n";
 175       incr count
 176     ) result_list;
 177     flush output;
 178     if output != stdout then close_out output
 179
 180   ) () "serializing results"
 181
 182
 183 let () =
 184   try
 185     main ()
 186   with
 187     Arg.Bad msg -> eprintf "Error: %s\n%!" msg; Options.usage (); exit 1
 188   | Sys_error msg -> eprintf "Error: %s\n%!" msg; exit 2
 189   | Tree.Parse_error msg ->
 190       eprintf "Error: %s, %s\n%!"
 191         (match !Options.input_file with
 192           Some s -> ("file " ^ s)
 193         | None -> "[stdin]") msg; exit 3
 194   | Xpath.Ulexer.Error (s, e, msg) -> eprintf "Error: character %i-%i: %s\n%!" s e msg; exit 4
 195 (*  | e -> Printexc.print_backtrace stderr;
 196     flush stderr;
 197     eprintf "FATAL ERROR: %s\n%!" (Printexc.to_string e); exit 128 *)