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
  18
  19
  20 let time f arg msg =
  21   let t1 = Unix.gettimeofday () in
  22   let r = f arg in
  23   let t2 = Unix.gettimeofday () in
  24   let time = (t2 -. t1) *. 1000. in
  25   Logger.msg `STATS "%s: %fms" msg time;
  26   r
  27
  28
  29 let compose_parallel run auto_list tree nodes () =
  30   match auto_list with
  31     [ auto ] -> [run auto tree nodes]
  32   | _ -> assert false
  33
  34 let compose_sequential run auto_list tree nodes () =
  35   [ List.fold_left (fun acc auto ->
  36     run auto tree acc) nodes auto_list ]
  37
  38
  39 let restart_parallel run auto_list tree nodes () =
  40   match auto_list with
  41     [ auto ] -> List.map snd (run auto tree nodes)
  42   | _ -> assert false
  43
  44 let restart_sequential run auto_list tree nodes () =
  45   List.map (fun auto -> run auto tree nodes) auto_list
  46
  47 let main () =
  48   let () = Options.parse () in
  49   let doc =
  50     let fd, close_fd = match !Options.input_file with
  51       None | Some "-" | Some "/dev/stdin" -> stdin, ignore
  52     | Some input ->
  53         let fd = open_in input in fd, fun () -> close_in fd
  54     in
  55     let d = time Naive_tree.load_xml_file fd "parsing xml document" in
  56     close_fd (); d
  57   in
  58   let queries =
  59     time
  60       (fun l ->
  61         List.map (fun q ->
  62           Xpath.Parser.parse
  63             (Ulexing.from_utf8_string q)) l)
  64       !Options.queries
  65       "parsing XPath queries"
  66   in
  67   (* parallel, compose  ->     action
  68      true, true -> Ata.concat of all automata and single run
  69      true, false -> Ata.merge of all automata and single run
  70      false, true -> Eval first, then run on results then ...
  71      false, false -> Eval first on root, then second on root then ...
  72   *)
  73   let auto_list =
  74     time
  75       (fun l ->
  76         List.map (fun query -> Xpath.Compile.path query) l)
  77       queries
  78       "compiling XPath queries"
  79   in
  80   let auto_list =
  81     if !Options.parallel then
  82       match auto_list with
  83         fst :: rest ->
  84           let f =
  85             if !Options.compose then
  86               Ata.concat
  87             else
  88               Ata.merge
  89           in
  90           let big_auto = List.fold_left f fst rest in
  91           [big_auto]
  92       | _ -> assert false
  93
  94     else
  95       auto_list
  96   in
  97   let output =
  98     match !Options.output_file with
  99     | None | Some "-" | Some "/dev/stdout" -> stdout
 100     | Some f -> open_out f
 101   in
 102   if !Options.stats then begin
 103     List.iter (fun query ->
 104       Logger.msg `STATS "Query: %a " Xpath.Ast.print_path query) queries;
 105     List.iter (fun auto ->
 106       Logger.msg `STATS "@[Automaton: @\n%a@]" Ata.print auto) auto_list;
 107   end;
 108
 109   let module Naive = Run.Make(Naive_tree) in
 110   let result_list =
 111     let root = [ Naive_tree.root doc] in
 112     let f, msg =
 113       match !Options.parallel, !Options.compose with
 114         true, true ->
 115           compose_parallel Naive.eval auto_list doc root, "parallel/compose"
 116       | true, false ->
 117           restart_parallel Naive.full_eval auto_list doc root, "parallel/restart"
 118       | false, true ->
 119           compose_sequential Naive.eval auto_list doc root , "sequential/compose"
 120       | false, false ->
 121           restart_sequential Naive.eval auto_list doc root, "sequential/restart"
 122     in
 123     time f () ("evaluating query in " ^ msg ^ " mode")
 124   in
 125   let s = Naive.stats () in
 126   Run.(
 127   Logger.msg `STATS
 128     "@[tree size: %d@\ntraversals: %d@\ntransition fetch cache hit ratio: %f@\ntransition eval cache hit ratio: %f@]"
 129     s.tree_size s.run
 130     (float s.fetch_trans_cache_hit /. float s.fetch_trans_cache_access)
 131     (float s.eval_trans_cache_hit /. float s.eval_trans_cache_access));
 132   time (fun () ->
 133     let count = ref 1 in
 134     List.iter (fun results ->
 135       output_string output "<xml_result num=\"";
 136       output_string output (string_of_int !count);
 137       output_string output "\" >\n";
 138       if !Options.count then begin
 139         output_string output (string_of_int (List.length results));
 140         output_char output '\n';
 141       end else
 142         List.iter (fun n ->
 143           Naive_tree.print_xml output doc n;
 144           output_char output '\n'
 145         ) results;
 146       output_string output "</xml_result>\n";
 147       incr count
 148     ) result_list;
 149     flush output;
 150     if output != stdout then close_out output
 151
 152   ) () "serializing results"
 153
 154
 155 let () =
 156   try
 157     main ()
 158   with
 159     Arg.Bad msg -> eprintf "Error: %s\n%!" msg; Options.usage (); exit 1
 160   | Sys_error msg -> eprintf "Error: %s\n%!" msg; exit 2
 161   | Tree.Parse_error msg ->
 162       eprintf "Error: %s, %s\n%!"
 163         (match !Options.input_file with
 164           Some s -> ("file " ^ s)
 165         | None -> "[stdin]") msg; exit 3
 166   | Xpath.Ulexer.Error (s, e, msg) -> eprintf "Error: character %i-%i: %s\n%!" s e msg; exit 4
 167   | e -> eprintf "FATAL ERROR: %s\n%!" (Printexc.to_string e); exit 128