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
24 type dir = DIR_LEFT | DIR_RIGHT
26 let _first_child s = Some (FIRST_CHILD s)
27 let _next_sibling s = Some (NEXT_SIBLING s)
28 let _first_element s = Some (FIRST_ELEMENT s)
29 let _next_element s = Some (NEXT_ELEMENT s)
30 let _tagged_descendant s t = Some (TAGGED_DESCENDANT(s,t))
31 let _tagged_following s t = Some (TAGGED_FOLLOWING(s,t))
32 let _select_descendant s t = Some (SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t))
33 let _select_following s t = Some (SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t))
34 let _tagged_child s t = Some (TAGGED_CHILD(s,t))
35 let _tagged_following_sibling s t = Some (TAGGED_FOLLOWING_SIBLING(s,t))
36 let _select_child s t = Some (SELECT_CHILD(s,t, Tree.unordered_set_of_set t))
37 let _select_following_sibling s t = Some (SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t))
38 let _tagged_subtree s t = Some (TAGGED_SUBTREE (s, t))
39 let _element_subtree s = Some (ELEMENT_SUBTREE s)
42 let jump_stat_table = Hashtbl.create 17
43 let jump_stat_init () = Hashtbl.clear jump_stat_table
45 let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in
46 Hashtbl.replace jump_stat_table j (i+1)
48 let print_jump fmt j =
50 | FIRST_CHILD _ -> fprintf fmt "first_child"
51 | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
52 | FIRST_ELEMENT _ -> fprintf fmt "first_element"
53 | NEXT_ELEMENT _ -> fprintf fmt "next_element"
55 | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag)
57 | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag)
59 | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)"
60 TagSet.print (TagSet.inj_positive tags)
62 | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)"
63 TagSet.print (TagSet.inj_positive tags)
65 | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
67 | TAGGED_FOLLOWING_SIBLING (_, tag) ->
68 fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
70 | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
71 TagSet.print (TagSet.inj_positive tags)
73 | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
74 TagSet.print (TagSet.inj_positive tags)
76 | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
77 | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree"
79 let jump_stat_summary fmt =
80 fprintf fmt "Jump function summary:\n%!";
81 Hashtbl.iter (fun k v -> fprintf fmt "%i calls to %a\n" v print_jump k) jump_stat_table;
88 | LEFT of Translist.t * jump
89 | RIGHT of Translist.t * jump
90 | BOTH of Translist.t * jump * jump
92 type t = opcode Cache.Lvl2.t
95 let print_opcode fmt o = match o with
96 | CACHE -> fprintf fmt "CACHE"
97 | RETURN -> fprintf fmt "RETURN"
98 | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
99 | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
100 | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
104 Cache.Lvl2.iteri (fun _ _ _ b -> if not b then incr count) a;
105 eprintf "%!L2JIT: %i used entries\n%!" !count
108 let v = Cache.Lvl2.create 4096 dummy in
109 if !Options.verbose then
110 at_exit (fun () -> show_stats v);
113 let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
115 let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v
117 let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) =
118 if TagSet.mem tag labels
120 let _, _, _, f = Transition.node tr in
121 let s1, s2 = Formula.st f in
122 (Translist.cons tr a_t,
123 StateSet.union s1 a_s1,
124 StateSet.union s2 a_s2)
127 let has_text l = Ptset.Int.mem Tag.pcdata l
129 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
130 let child, desc, sib, fol = Tree.tags tree tag in
131 match jkind, dir with
133 | NODE, DIR_LEFT -> Some (FIRST_CHILD s)
134 | STAR, DIR_LEFT -> Some (FIRST_ELEMENT s)
135 | NODE, DIR_RIGHT -> Some (NEXT_SIBLING s)
136 | STAR, DIR_RIGHT -> Some (NEXT_ELEMENT s)
138 let l_one, l_many, tagged_one, select_one, any, any_notext =
139 if dir = DIR_LEFT then
140 child, desc, _tagged_child, _select_child,_first_child, _first_element
142 sib, fol, _tagged_following_sibling, _select_following_sibling,
143 _next_sibling, _next_element
145 let labels = Ptset.Int.inter l_one t in
146 let c = Ptset.Int.cardinal labels in
148 else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
149 translate_jump tree tag (JUMP_MANY(labels)) dir s
150 else if c == 1 then tagged_one s (Ptset.Int.choose labels)
151 else if c > 5 then if has_text labels then any s else any_notext s
152 else select_one s labels
155 let l_many, tagged_many, select_many, any, any_notext =
156 if dir == DIR_LEFT then
157 desc, _tagged_descendant, _select_descendant,_first_child, _first_element
159 fol, _tagged_following, _select_following, _next_sibling, _next_element
161 let labels = Ptset.Int.inter l_many t in
162 let c = Ptset.Int.cardinal labels in
164 else if c == 1 then tagged_many s (Ptset.Int.choose labels)
165 else if c > 5 then if has_text labels then any s else any_notext s
166 else select_many s labels
168 | CAPTURE_MANY (t), DIR_LEFT ->
169 if Ptset.Int.is_singleton t then Some (TAGGED_SUBTREE(s, Ptset.Int.choose t))
170 else if t == Tree.element_tags tree then Some (ELEMENT_SUBTREE s)
174 let compute_jump auto tree tag states dir =
175 if !Options.no_jump then
176 if dir == DIR_LEFT then Some (FIRST_CHILD states)
177 else Some (NEXT_SIBLING states)
179 let jkind = Ata.top_down_approx auto states tree in
180 translate_jump tree tag jkind dir states
182 let mk_left tr_list j =
184 Some x -> LEFT(tr_list, x)
187 let mk_right tr_list j =
189 Some x -> RIGHT(tr_list, x)
192 let mk_both tr_list j1 j2 =
194 | Some x1, Some x2 -> BOTH(tr_list, x1, x2)
195 | None, Some x -> RIGHT(tr_list,x)
196 | Some x, None -> LEFT(tr_list, x)
197 | None, None -> RETURN
199 let compile cache2 auto tree tag states =
200 let tr_list, states1, states2 =
203 List.fold_left (collect_trans tag)
205 (Hashtbl.find auto.trans q))
207 (Translist.nil, StateSet.empty, StateSet.empty)
210 let empty_s1 = StateSet.is_empty states1 in
211 let empty_s2 = StateSet.is_empty states2 in
212 if empty_s1 && empty_s2 then RETURN
213 else if empty_s1 then
215 (compute_jump auto tree tag states2 DIR_RIGHT)
216 else if empty_s2 then
218 (compute_jump auto tree tag states1 DIR_LEFT)
220 let j1 = compute_jump auto tree tag states1 DIR_LEFT in
221 let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
222 mk_both tr_list j1 j2
224 add cache2 tag states op;
227 let get_transitions = function
228 | CACHE | RETURN -> failwith "get_transitions"
231 | BOTH (tr, _, _) -> tr