10 | FIRST_CHILD of StateSet.t
11 | NEXT_SIBLING of StateSet.t
12 | FIRST_ELEMENT of StateSet.t
13 | NEXT_ELEMENT of StateSet.t
14 | TAGGED_DESCENDANT of StateSet.t * Tag.t
15 | TAGGED_FOLLOWING of StateSet.t * Tag.t
16 | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.unordered_set
17 | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.unordered_set
18 | TAGGED_CHILD of StateSet.t * Tag.t
19 | TAGGED_FOLLOWING_SIBLING of StateSet.t * Tag.t
20 | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.unordered_set
21 | SELECT_FOLLOWING_SIBLING of StateSet.t * Ptset.Int.t * Tree.unordered_set
22 | TAGGED_SUBTREE of StateSet.t * Tag.t
23 | ELEMENT_SUBTREE of StateSet.t
25 type dir = DIR_LEFT | DIR_RIGHT
28 let _first_child s = FIRST_CHILD s
29 let _next_sibling s = NEXT_SIBLING s
30 let _first_element s = FIRST_ELEMENT s
31 let _next_element s = NEXT_ELEMENT s
32 let _tagged_descendant s t = TAGGED_DESCENDANT(s,t)
33 let _tagged_following s t = TAGGED_FOLLOWING(s,t)
34 let _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t)
35 let _select_following s t = SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t)
36 let _tagged_child s t = TAGGED_CHILD(s,t)
37 let _tagged_following_sibling s t = TAGGED_FOLLOWING_SIBLING(s,t)
38 let _select_child s t = SELECT_CHILD(s,t, Tree.unordered_set_of_set t)
39 let _select_following_sibling s t = SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t)
40 let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
41 let _element_subtree s = ELEMENT_SUBTREE s
44 let jump_stat_table = Hashtbl.create 17
45 let jump_stat_init () = Hashtbl.clear jump_stat_table
47 let i = try Hashtbl.find jump_stat_table j with Not_found -> 0 in
48 Hashtbl.replace jump_stat_table j (i+1)
50 let print_jump fmt j =
52 | NOP _ -> fprintf fmt "nop"
53 | FIRST_CHILD _ -> fprintf fmt "first_child"
54 | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
55 | FIRST_ELEMENT _ -> fprintf fmt "first_element"
56 | NEXT_ELEMENT _ -> fprintf fmt "next_element"
58 | TAGGED_DESCENDANT (_, tag) -> fprintf fmt "tagged_descendant(%s)" (Tag.to_string tag)
60 | TAGGED_FOLLOWING (_, tag) -> fprintf fmt "tagged_following(%s)" (Tag.to_string tag)
62 | SELECT_DESCENDANT (_, tags, _) -> fprintf fmt "select_descendant(%a)"
63 TagSet.print (TagSet.inj_positive tags)
65 | SELECT_FOLLOWING (_, tags, _) -> fprintf fmt "select_following(%a)"
66 TagSet.print (TagSet.inj_positive tags)
68 | TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
70 | TAGGED_FOLLOWING_SIBLING (_, tag) ->
71 fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
73 | SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
74 TagSet.print (TagSet.inj_positive tags)
76 | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
77 TagSet.print (TagSet.inj_positive tags)
79 | TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
80 | ELEMENT_SUBTREE (_) -> fprintf fmt "element_subtree"
82 let jump_stat_summary fmt =
83 fprintf fmt "Jump function summary:\n%!";
84 Hashtbl.iter (fun k v -> fprintf fmt "%i calls to %a\n" v print_jump k) jump_stat_table;
91 | LEFT of Translist.t * jump
92 | RIGHT of Translist.t * jump
93 | BOTH of Translist.t * jump * jump
95 type t = opcode Cache.Lvl2.t
98 let print_opcode fmt o = match o with
99 | CACHE -> fprintf fmt "CACHE"
100 | RETURN -> fprintf fmt "RETURN"
101 | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
102 | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
103 | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
105 let print_cache fmt d =
106 let c = Cache.Lvl2.to_array d in
107 Array.iteri begin fun tag a ->
108 let tagstr = Tag.to_string tag in
109 if a != Cache.Lvl2.dummy_line d && tagstr <> "<INVALID TAG>"
111 fprintf fmt "Entry %s: \n" tagstr;
112 Array.iter (fun o -> if o != dummy then begin
114 fprintf fmt "\n%!" end) a;
115 fprintf fmt "---------------------------\n%!"
119 let create () = Cache.Lvl2.create 4096 dummy
122 let d = Cache.Lvl2.to_array c in
123 let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in
124 let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
125 let lvl2 = Array.fold_left (fun acc a ->
126 Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1)
129 fprintf fmt "L2JIT Statistics:
133 \ttable size: %ikb\n"
134 len lvl1 lvl2 (Ocaml.size_kb d);
135 fprintf fmt "%s" "L2JIT Content:\n";
139 let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
141 let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v
144 let has_text l = Ptset.Int.mem Tag.pcdata l
146 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
147 let child, desc, sib, fol = Tree.tags tree tag in
148 match jkind, dir with
150 | NODE, DIR_LEFT -> FIRST_CHILD s
151 | STAR, DIR_LEFT -> FIRST_ELEMENT s
152 | NODE, DIR_RIGHT -> NEXT_SIBLING s
153 | STAR, DIR_RIGHT -> NEXT_ELEMENT s
155 let l_one, l_many, tagged_one, select_one, any, any_notext =
156 if dir = DIR_LEFT then
157 child, desc, _tagged_child, _select_child,_first_child, _first_element
159 sib, fol, _tagged_following_sibling, _select_following_sibling,
160 _next_sibling, _next_element
162 let labels = Ptset.Int.inter l_one t in
163 let c = Ptset.Int.cardinal labels in
165 else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
166 translate_jump tree tag (JUMP_MANY(labels)) dir s
167 else if c == 1 then tagged_one s (Ptset.Int.choose labels)
168 else if c > 5 then if has_text labels then any s else any_notext s
169 else select_one s labels
172 let l_many, tagged_many, select_many, any, any_notext =
173 if dir == DIR_LEFT then
174 desc, _tagged_descendant, _select_descendant,_first_child, _first_element
176 fol, _tagged_following, _select_following, _next_sibling, _next_element
178 let labels = Ptset.Int.inter l_many t in
179 let c = Ptset.Int.cardinal labels in
181 else if c == 1 then tagged_many s (Ptset.Int.choose labels)
182 else if c > 5 then if has_text labels then any s else any_notext s
183 else select_many s labels
185 | CAPTURE_MANY (t), DIR_LEFT ->
186 if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t)
187 else if t == Tree.element_tags tree then ELEMENT_SUBTREE s
191 let compute_jump auto tree tag states dir =
192 if !Options.no_jump then
193 if dir == DIR_LEFT then FIRST_CHILD states
194 else NEXT_SIBLING states
196 let jkind = Ata.top_down_approx auto states tree in
197 let jump = translate_jump tree tag jkind dir states in
198 LOG(__ "level2-jit" 2
199 "Computed jumps for %s %a %s: %a\n%!"
201 StateSet.print states
202 (if dir == DIR_LEFT then "left" else "right")
207 let compile cache2 auto tree tag states =
208 let tr_list, states1, states2 =
209 Ata.get_trans ~attributes:(TagSet.inj_positive (Tree.attribute_tags tree)) auto states tag
212 let empty_s1 = StateSet.is_empty states1 in
213 let empty_s2 = StateSet.is_empty states2 in
214 if empty_s1 && empty_s2 then RETURN
215 else if empty_s1 then
217 compute_jump auto tree tag states2 DIR_RIGHT)
218 else if empty_s2 then
220 compute_jump auto tree tag states1 DIR_LEFT)
222 let j1 = compute_jump auto tree tag states1 DIR_LEFT in
223 let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
224 BOTH (tr_list, j1, j2);
226 let op = match op with
227 (*BOTH(_, NOP _, NOP _) | LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
228 | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l)
229 | BOTH(tr, l, NOP _) -> LEFT (tr, l)
230 | BOTH(tr, NOP _, r) -> RIGHT (tr, r)
233 add cache2 tag states op;
236 let get_transitions = function
237 | CACHE | RETURN -> failwith "get_transitions"
240 | BOTH (tr, _, _) -> tr