Merge branch 'local-ocamlbuild' into local-trunk
[SXSI/xpathcomp.git] / src / l2JIT.ml
1 INCLUDE "debug.ml"
2 INCLUDE "utils.ml"
3
4 open Format
5 open Ata
6
7 type jump =
8   | NOP of unit
9   | FIRST_CHILD of StateSet.t
10   | NEXT_SIBLING of StateSet.t
11   | FIRST_ELEMENT of StateSet.t
12   | NEXT_ELEMENT of StateSet.t
13   | TAGGED_DESCENDANT of StateSet.t * Tag.t
14   | TAGGED_FOLLOWING of StateSet.t * Tag.t
15   | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.unordered_set
16   | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.unordered_set
17   | TAGGED_CHILD of StateSet.t * Tag.t
18   | TAGGED_FOLLOWING_SIBLING of StateSet.t * Tag.t
19   | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.unordered_set
20   | SELECT_FOLLOWING_SIBLING of StateSet.t * Ptset.Int.t * Tree.unordered_set
21   | TAGGED_SUBTREE of StateSet.t * Tag.t
22   | ELEMENT_SUBTREE of StateSet.t
23
24 type dir = DIR_LEFT | DIR_RIGHT
25
26 let _nop = NOP ()
27 let _first_child s = FIRST_CHILD s
28 let _next_sibling s = NEXT_SIBLING s
29 let _first_element s = FIRST_ELEMENT s
30 let _next_element s = NEXT_ELEMENT s
31 let _tagged_descendant s t = TAGGED_DESCENDANT(s,t)
32 let _tagged_following s t = TAGGED_FOLLOWING(s,t)
33 let _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t)
34 let _select_following s t = SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t)
35 let _tagged_child s t = TAGGED_CHILD(s,t)
36 let _tagged_following_sibling s t = TAGGED_FOLLOWING_SIBLING(s,t)
37 let _select_child s t = SELECT_CHILD(s,t, Tree.unordered_set_of_set t)
38 let _select_following_sibling s t = SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t)
39 let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
40 let _element_subtree s = ELEMENT_SUBTREE s
41
42
43 let jump_stat_table = Hashtbl.create 17
44 let jump_stat_init () = Hashtbl.clear jump_stat_table
45 let jump_stat j =
46   let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in
47     Hashtbl.replace jump_stat_table j (i+1)
48
49 let print_jump fmt j =
50   match j with
51     | NOP _ -> fprintf fmt "nop"
52     | FIRST_CHILD _ -> fprintf fmt "first_child"
53     | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
54     | FIRST_ELEMENT _ -> fprintf fmt "first_element"
55     | NEXT_ELEMENT _ -> fprintf fmt "next_element"
56
57     | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag)
58
59     | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag)
60
61     | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)"
62         TagSet.print (TagSet.inj_positive tags)
63
64     | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)"
65         TagSet.print (TagSet.inj_positive tags)
66
67     | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
68
69     | TAGGED_FOLLOWING_SIBLING (_, tag) ->
70         fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
71
72     | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
73         TagSet.print (TagSet.inj_positive tags)
74
75     | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
76         TagSet.print (TagSet.inj_positive tags)
77
78     | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
79     | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree"
80
81 let jump_stat_summary fmt =
82   fprintf fmt "Jump function summary:\n%!";
83   Hashtbl.iter (fun k v -> fprintf fmt "%i calls to %a\n" v print_jump k) jump_stat_table;
84   fprintf fmt "%!"
85
86
87 type opcode =
88   | CACHE of unit
89   | RETURN of unit
90   | LEFT of Translist.t * jump
91   | RIGHT of Translist.t * jump
92   | BOTH of Translist.t * jump * jump
93
94 type t = opcode Cache.Lvl2.t
95 let dummy = CACHE()
96 let print_opcode fmt o = match o with
97   | CACHE _ -> fprintf fmt "CACHE()"
98   | RETURN _ -> fprintf fmt "RETURN ()"
99   | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
100   | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
101   | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
102
103 let print_cache fmt d =
104   let c = Cache.Lvl2.to_array d in
105   Array.iteri begin fun tag a ->
106     let tagstr = Tag.to_string tag in
107     if a != Cache.Lvl2.dummy_line d && tagstr <> "<INVALID TAG>"
108     then begin
109       fprintf fmt "Entry %s: \n" tagstr;
110       Array.iter (fun o -> if o != dummy then begin
111         print_opcode fmt o;
112         fprintf fmt "\n%!" end) a;
113       fprintf fmt "---------------------------\n%!"
114     end
115   end c
116
117 let create () = Cache.Lvl2.create 1024 dummy
118
119 let stats fmt c =
120   let d = Cache.Lvl2.to_array c in
121   let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in
122   let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
123   let lvl2 = Array.fold_left (fun acc a ->
124                                 Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1)
125                                   acc a) 0 d
126   in
127   fprintf fmt "L2JIT Statistics:
128 \t%i entries
129 \t%i used L1 lines
130 \t%i used L2 lines
131 \ttable size: %ikb\n"
132       len lvl1 lvl2 (Ocaml.size_kb d);
133   fprintf fmt "%s" "L2JIT Content:\n";
134   print_cache fmt c
135
136 let find t tag set = Cache.Lvl2.find t tag (Uid.to_int set.StateSet.Node.id)
137
138 let add t tag set v = Cache.Lvl2.add t tag (Uid.to_int set.StateSet.Node.id) v
139
140 let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) =
141   if TagSet.mem tag labels
142   then
143     let _, _, _, f = Transition.node tr in
144     let (_, _, s1), (_, _, s2) = Formula.st f in
145       (Translist.cons tr a_t,
146        StateSet.union s1 a_s1,
147        StateSet.union s2 a_s2)
148   else acc
149
150 let has_text l = Ptset.Int.mem Tag.pcdata l
151
152 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
153   let child, desc, sib, fol = Tree.tags tree tag in
154      match jkind, dir with
155       | NIL, _ -> _nop
156       | NODE, DIR_LEFT -> FIRST_CHILD s
157       | STAR, DIR_LEFT -> FIRST_ELEMENT s
158       | NODE, DIR_RIGHT -> NEXT_SIBLING s
159       | STAR, DIR_RIGHT -> NEXT_ELEMENT s
160       | JUMP_ONE t, _ ->
161           let l_one, l_many, tagged_one, select_one, any, any_notext =
162             if dir = DIR_LEFT then
163               child, desc, _tagged_child, _select_child,_first_child, _first_element
164             else
165               sib, fol, _tagged_following_sibling, _select_following_sibling,
166             _next_sibling, _next_element
167           in
168           let labels = Ptset.Int.inter l_one t in
169           let c = Ptset.Int.cardinal labels in
170             if c == 0 then _nop
171             else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels
172             then translate_jump tree tag (JUMP_MANY(labels)) dir s
173             else if c == 1 then tagged_one s (Ptset.Int.choose labels)
174             else if c > 5 then if has_text labels then any s else any_notext s
175             else select_one s labels
176
177       | JUMP_MANY t, _ ->
178           let l_many, tagged_many, select_many, any, any_notext =
179             if dir == DIR_LEFT then
180               desc, _tagged_descendant, _select_descendant,_first_child, _first_element
181             else
182               fol, _tagged_following, _select_following, _next_sibling, _next_element
183           in
184           let labels = Ptset.Int.inter l_many t in
185           let c = Ptset.Int.cardinal labels in
186             if c == 0 then _nop
187             else if c == 1 then tagged_many s (Ptset.Int.choose labels)
188             else if c > 5 then if has_text labels then any s else any_notext s
189             else select_many s labels
190
191       | CAPTURE_MANY (t), DIR_LEFT ->
192           if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t)
193           else if t == Tree.element_tags tree then ELEMENT_SUBTREE s
194           else assert false
195       | _ -> assert false
196
197 let compute_jump auto tree tag states dir =
198   (*PROF_CFUN("L2JIT.compute_jump"); *)
199   if !Options.no_jump then
200     if dir == DIR_LEFT then FIRST_CHILD states
201     else NEXT_SIBLING states
202   else
203     let jkind = Ata.top_down_approx auto states tree in
204     let jump = translate_jump tree tag jkind dir states in
205       D_TRACE_(eprintf "Computed jumps for %s %a %s: %a\n%!"
206                  (Tag.to_string tag)
207                  StateSet.print states
208                  (if dir == DIR_LEFT then "left" else "right")
209                  print_jump jump);
210       jump
211
212 let compile cache2 auto tree tag states =
213   (*PROF_CFUN("L2JIT.compile"); *)
214   let tr_list, states1, states2 =
215     StateSet.fold
216       (fun q acc ->
217          List.fold_left (collect_trans tag)
218            acc
219            (Hashtbl.find auto.trans q))
220       states
221       (Translist.nil, StateSet.empty, StateSet.empty)
222   in
223   let op =
224     let empty_s1 = StateSet.is_empty states1 in
225     let empty_s2 = StateSet.is_empty states2 in
226       if empty_s1 && empty_s2 then RETURN ()
227       else if empty_s1 then
228         RIGHT (tr_list,
229                compute_jump auto tree tag states2 DIR_RIGHT)
230       else if empty_s2 then
231         LEFT (tr_list,
232               compute_jump auto tree tag states1 DIR_LEFT)
233       else
234         BOTH (tr_list,
235               compute_jump auto tree tag states1 DIR_LEFT,
236               compute_jump auto tree tag states2 DIR_RIGHT)
237   in
238   let op = match op with
239       (*BOTH(_, NOP _, NOP _) |  LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
240     | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l)
241     | BOTH(tr, l, NOP _) -> LEFT (tr, l)
242     | BOTH(tr, NOP _, r) -> RIGHT (tr, r)
243     | _ -> op
244   in
245     add cache2 tag states op;
246     op
247
248 let get_transitions = function
249   | CACHE _ | RETURN _ -> failwith "get_transitions"
250   | LEFT (tr, _)
251   | RIGHT (tr, _)
252   | BOTH (tr, _, _) -> tr
253