open Ata
type jump =
- | NOP of unit
| FIRST_CHILD of StateSet.t
| NEXT_SIBLING of StateSet.t
| FIRST_ELEMENT of StateSet.t
| ELEMENT_SUBTREE of StateSet.t
type dir = DIR_LEFT | DIR_RIGHT
-
-let _nop = NOP ()
-let _first_child s = FIRST_CHILD s
-let _next_sibling s = NEXT_SIBLING s
-let _first_element s = FIRST_ELEMENT s
-let _next_element s = NEXT_ELEMENT s
-let _tagged_descendant s t = TAGGED_DESCENDANT(s,t)
-let _tagged_following s t = TAGGED_FOLLOWING(s,t)
-let _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t)
-let _select_following s t = SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t)
-let _tagged_child s t = TAGGED_CHILD(s,t)
-let _tagged_following_sibling s t = TAGGED_FOLLOWING_SIBLING(s,t)
-let _select_child s t = SELECT_CHILD(s,t, Tree.unordered_set_of_set t)
-let _select_following_sibling s t = SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t)
-let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
-let _element_subtree s = ELEMENT_SUBTREE s
+let _nop = None
+let _first_child s = Some (FIRST_CHILD s)
+let _next_sibling s = Some (NEXT_SIBLING s)
+let _first_element s = Some (FIRST_ELEMENT s)
+let _next_element s = Some (NEXT_ELEMENT s)
+let _tagged_descendant s t = Some (TAGGED_DESCENDANT(s,t))
+let _tagged_following s t = Some (TAGGED_FOLLOWING(s,t))
+let _select_descendant s t = Some (SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t))
+let _select_following s t = Some (SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t))
+let _tagged_child s t = Some (TAGGED_CHILD(s,t))
+let _tagged_following_sibling s t = Some (TAGGED_FOLLOWING_SIBLING(s,t))
+let _select_child s t = Some (SELECT_CHILD(s,t, Tree.unordered_set_of_set t))
+let _select_following_sibling s t = Some (SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t))
+let _tagged_subtree s t = Some (TAGGED_SUBTREE (s, t))
+let _element_subtree s = Some (ELEMENT_SUBTREE s)
let jump_stat_table = Hashtbl.create 17
let print_jump fmt j =
match j with
- | NOP _ -> fprintf fmt "nop"
| FIRST_CHILD _ -> fprintf fmt "first_child"
| NEXT_SIBLING _ -> fprintf fmt "next_sibling"
| FIRST_ELEMENT _ -> fprintf fmt "first_element"
| LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
| RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
| BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
-(*
-let print_cache fmt d =
- let c = Cache.Lvl2.to_array d in
- Array.iteri begin fun tag a ->
- let tagstr = Tag.to_string tag in
- if a != Cache.Lvl2.dummy_line d && tagstr <> "<INVALID TAG>"
- then begin
- fprintf fmt "Entry %s: \n" tagstr;
- Array.iter (fun o -> if o != dummy then begin
- print_opcode fmt o;
- fprintf fmt "\n%!" end) a;
- fprintf fmt "---------------------------\n%!"
- end
- end c
-*)
-let create () = Cache.Lvl2.create 4096 dummy
-(*
-let stats fmt c =
- let d = Cache.Lvl2.to_array c in
- let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in
- let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
- let lvl2 = Array.fold_left (fun acc a ->
- Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1)
- acc a) 0 d
- in
- fprintf fmt "L2JIT Statistics:
-\t%i entries
-\t%i used L1 lines
-\t%i used L2 lines
-\ttable size: %ikb\n"
- len lvl1 lvl2 (Ocaml.size_kb d);
- fprintf fmt "%s" "L2JIT Content:\n";
- print_cache fmt c
-*)
+
+let show_stats a =
+ let count = ref 0 in
+ Cache.Lvl2.iteri (fun _ _ _ b -> if not b then incr count) a;
+ eprintf "%!L2JIT: %i used entries\n%!" !count
+
+let create () =
+ let v = Cache.Lvl2.create 4096 dummy in
+ if !Options.verbose then
+ at_exit (fun () -> show_stats v);
+ v
let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
let child, desc, sib, fol = Tree.tags tree tag in
match jkind, dir with
- | NIL, _ -> _nop
- | NODE, DIR_LEFT -> FIRST_CHILD s
- | STAR, DIR_LEFT -> FIRST_ELEMENT s
- | NODE, DIR_RIGHT -> NEXT_SIBLING s
- | STAR, DIR_RIGHT -> NEXT_ELEMENT s
+ | NIL, _ -> None
+ | NODE, DIR_LEFT -> Some (FIRST_CHILD s)
+ | STAR, DIR_LEFT -> Some (FIRST_ELEMENT s)
+ | NODE, DIR_RIGHT -> Some (NEXT_SIBLING s)
+ | STAR, DIR_RIGHT -> Some (NEXT_ELEMENT s)
| JUMP_ONE t, _ ->
let l_one, l_many, tagged_one, select_one, any, any_notext =
if dir = DIR_LEFT then
in
let labels = Ptset.Int.inter l_one t in
let c = Ptset.Int.cardinal labels in
- if c == 0 then _nop
+ if c == 0 then None
else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
translate_jump tree tag (JUMP_MANY(labels)) dir s
else if c == 1 then tagged_one s (Ptset.Int.choose labels)
else select_many s labels
| CAPTURE_MANY (t), DIR_LEFT ->
- if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t)
- else if t == Tree.element_tags tree then ELEMENT_SUBTREE s
+ if Ptset.Int.is_singleton t then Some (TAGGED_SUBTREE(s, Ptset.Int.choose t))
+ else if t == Tree.element_tags tree then Some (ELEMENT_SUBTREE s)
else assert false
| _ -> assert false
let compute_jump auto tree tag states dir =
if !Options.no_jump then
- if dir == DIR_LEFT then FIRST_CHILD states
- else NEXT_SIBLING states
+ if dir == DIR_LEFT then Some (FIRST_CHILD states)
+ else Some (NEXT_SIBLING states)
else
let jkind = Ata.top_down_approx auto states tree in
- let jump = translate_jump tree tag jkind dir states in
- TRACE("level2-jit", 2,
- __ "Computed jumps for %s %a %s: %a\n%!"
- (Tag.to_string tag)
- StateSet.print states
- (if dir == DIR_LEFT then "left" else "right")
- print_jump jump
- );
- jump
+ translate_jump tree tag jkind dir states
+
+let mk_left tr_list j =
+ match j with
+ Some x -> LEFT(tr_list, x)
+ | _ -> RETURN
+
+let mk_right tr_list j =
+ match j with
+ Some x -> RIGHT(tr_list, x)
+ | _ -> RETURN
+
+let mk_both tr_list j1 j2 =
+ match j1, j2 with
+ | Some x1, Some x2 -> BOTH(tr_list, x1, x2)
+ | None, Some x -> RIGHT(tr_list,x)
+ | Some x, None -> LEFT(tr_list, x)
+ | None, None -> RETURN
let compile cache2 auto tree tag states =
let tr_list, states1, states2 =
let empty_s2 = StateSet.is_empty states2 in
if empty_s1 && empty_s2 then RETURN
else if empty_s1 then
- RIGHT (tr_list,
- compute_jump auto tree tag states2 DIR_RIGHT)
+ mk_right tr_list
+ (compute_jump auto tree tag states2 DIR_RIGHT)
else if empty_s2 then
- LEFT (tr_list,
- compute_jump auto tree tag states1 DIR_LEFT)
+ mk_left tr_list
+ (compute_jump auto tree tag states1 DIR_LEFT)
else
let j1 = compute_jump auto tree tag states1 DIR_LEFT in
let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
- BOTH (tr_list, j1, j2);
- in
- let op = match op with
- (*BOTH(_, NOP _, NOP _) | LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
- | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l)
- | BOTH(tr, l, NOP _) -> LEFT (tr, l)
- | BOTH(tr, NOP _, r) -> RIGHT (tr, r)
- | _ -> op
+ mk_both tr_list j1 j2
in
add cache2 tag states op;
op
projects / SXSI / xpathcomp.git / commitdiff