Add a new option to choose tree model at runtime.
[tatoo.git] / 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 queries =
76     time
77       (fun l ->
78         List.map (fun q ->
79           Xpath.Parser.parse
80             (Ulexing.from_utf8_string q)) l)
81       !Options.queries
82       "parsing XPath queries"
83   in
84   (* parallel, compose  ->     action
85      true, true -> Ata.concat of all automata and single run
86      true, false -> Ata.merge of all automata and single run
87      false, true -> Eval first, then run on results then ...
88      false, false -> Eval first on root, then second on root then ...
89   *)
90   let auto_list =
91     time
92       (fun l ->
93         List.map (fun query -> Xpath.Compile.path query) l)
94       queries
95       "compiling XPath queries"
96   in
97   let auto_list =
98     if !Options.parallel then
99       match auto_list with
100         fst :: rest ->
101           let f =
102             if !Options.compose then
103               Ata.concat
104             else
105               Ata.merge
106           in
107           let big_auto = List.fold_left f fst rest in
108           [big_auto]
109       | _ -> assert false
110
111     else
112       auto_list
113   in
114   let output =
115     match !Options.output_file with
116     | None | Some "-" | Some "/dev/stdout" -> stdout
117     | Some f -> open_out f
118   in
119   if !Options.stats then begin
120     List.iter (fun query ->
121       Logger.msg `STATS "Query: %a " Xpath.Ast.print_path query) queries;
122     List.iter (fun auto ->
123       Logger.msg `STATS "@[Automaton: @\n%a@]" Ata.print auto) auto_list;
124   end;
125
126   let result_list =
127     let root = Runtime.ResultSet.create () in
128     let () =  Runtime.ResultSet.add (Runtime.Tree.root doc) root in
129     let f, msg =
130       match !Options.parallel, !Options.compose with
131         true, true ->
132           compose_parallel Runtime.eval auto_list doc root, "parallel/compose"
133       | true, false ->
134           restart_parallel Runtime.full_eval auto_list doc root, "parallel/restart"
135       | false, true ->
136           compose_sequential Runtime.eval auto_list doc root , "sequential/compose"
137       | false, false ->
138           restart_sequential Runtime.eval auto_list doc root, "sequential/restart"
139     in
140     time f () ("evaluating query in " ^ msg ^ " mode")
141   in
142   let s = Runtime.stats () in
143   Run.(
144   Logger.msg `STATS
145     "@[tree size: %d@\ntraversals: %d@\ntransition fetch cache miss ratio: %f@\ntransition eval cache miss ratio: %f@\nNumber of visited nodes per pass: %a@]"
146     s.tree_size s.pass
147     (float s.fetch_trans_cache_miss /. float s.fetch_trans_cache_access)
148     (float s.eval_trans_cache_miss /. float s.eval_trans_cache_access)
149     (let i = ref 0 in
150      Pretty.print_list ~sep:"," (fun fmt n -> Format.fprintf fmt "%i: %i" !i n;incr i))
151     s.nodes_per_run);
152   time (fun () ->
153     let count = ref 1 in
154     List.iter (fun results ->
155       output_string output "<xml_result num=\"";
156       output_string output (string_of_int !count);
157       output_string output "\" >\n";
158       if !Options.count then begin
159         output_string output (string_of_int (Runtime.ResultSet.length results));
160         output_char output '\n';
161       end else
162         Runtime.ResultSet.iter (fun n ->
163             Runtime.Tree.print_xml output doc n;
164           output_char output '\n'
165         ) results;
166       output_string output "</xml_result>\n";
167       incr count
168     ) result_list;
169     flush output;
170     if output != stdout then close_out output
171
172   ) () "serializing results"
173
174
175 let () =
176   try
177     main ()
178   with
179     Arg.Bad msg -> eprintf "Error: %s\n%!" msg; Options.usage (); exit 1
180   | Sys_error msg -> eprintf "Error: %s\n%!" msg; exit 2
181   | Tree.Parse_error msg ->
182       eprintf "Error: %s, %s\n%!"
183         (match !Options.input_file with
184           Some s -> ("file " ^ s)
185         | None -> "[stdin]") msg; exit 3
186   | Xpath.Ulexer.Error (s, e, msg) -> eprintf "Error: character %i-%i: %s\n%!" s e msg; exit 4
187 (*  | e -> Printexc.print_backtrace stderr;
188     flush stderr;
189     eprintf "FATAL ERROR: %s\n%!" (Printexc.to_string e); exit 128 *)