| NEXT_ELEMENT of StateSet.t
| TAGGED_DESCENDANT of StateSet.t * Tag.t
| TAGGED_FOLLOWING of StateSet.t * Tag.t
- | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.unordered_set
- | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.unordered_set
+ | SELECT_DESCENDANT of StateSet.t * Ptset.Int.t * Tree.tag_list
+ | SELECT_FOLLOWING of StateSet.t * Ptset.Int.t * Tree.tag_list
| TAGGED_CHILD of StateSet.t * Tag.t
- | TAGGED_FOLLOWING_SIBLING of StateSet.t * Tag.t
- | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.unordered_set
- | SELECT_FOLLOWING_SIBLING of StateSet.t * Ptset.Int.t * Tree.unordered_set
+ | TAGGED_SIBLING of StateSet.t * Tag.t
+ | SELECT_CHILD of StateSet.t * Ptset.Int.t * Tree.tag_list
+ | SELECT_SIBLING of StateSet.t * Ptset.Int.t * Tree.tag_list
| TAGGED_SUBTREE of StateSet.t * Tag.t
| ELEMENT_SUBTREE of StateSet.t
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 _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.tag_list_of_set t)
+let _select_following s t = SELECT_FOLLOWING(s,t, Tree.tag_list_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_following_sibling s t = TAGGED_SIBLING(s,t)
+let _select_child s t = SELECT_CHILD(s,t, Tree.tag_list_of_set t)
+let _select_following_sibling s t = SELECT_SIBLING(s,t, Tree.tag_list_of_set t)
let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
let _element_subtree s = ELEMENT_SUBTREE s
| TAGGED_CHILD (_, tag) -> fprintf fmt "tagged_child(%s)" (Tag.to_string tag)
- | TAGGED_FOLLOWING_SIBLING (_, tag) ->
+ | TAGGED_SIBLING (_, tag) ->
fprintf fmt "tagged_following_sibling(%s)" (Tag.to_string tag)
| SELECT_CHILD (_, tags, _) -> fprintf fmt "select_child(%a)"
TagSet.print (TagSet.inj_positive tags)
- | SELECT_FOLLOWING_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
+ | SELECT_SIBLING (_, tags, _) -> fprintf fmt "select_following_sibling(%a)"
TagSet.print (TagSet.inj_positive tags)
| TAGGED_SUBTREE (_, tag) -> fprintf fmt "tagged_subtree(%s)" (Tag.to_string tag)
type opcode =
- | CACHE
- | RETURN
+ | RETURN of unit
| LEFT of Translist.t * jump
| RIGHT of Translist.t * jump
| BOTH of Translist.t * jump * jump
+ | CACHE of unit
type t = opcode Cache.Lvl2.t
-let dummy = CACHE
+let dummy = CACHE ()
+let return = RETURN ()
let print_opcode fmt o = match o with
- | CACHE -> fprintf fmt "CACHE"
- | RETURN -> fprintf fmt "RETURN"
+ | CACHE _ -> fprintf fmt "CACHE"
+ | RETURN _ -> fprintf fmt "RETURN"
| 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
end
end c
*)
-let create () = Cache.Lvl2.create 4096 dummy
+let create () = Cache.Lvl2.create 512 dummy
(*
let stats fmt c =
let d = Cache.Lvl2.to_array c in
let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
let child, desc, sib, fol = Tree.tags tree tag in
+ let not_elements =
+ Ptset.Int.add Tag.pcdata
+ (Ptset.Int.add Tag.attribute
+ (Ptset.Int.add Tag.attribute_data
+ (Tree.attribute_tags tree)))
+ in
match jkind, dir with
| NIL, _ -> _nop
| NODE, DIR_LEFT -> FIRST_CHILD s
let labels = Ptset.Int.inter l_many t in
let c = Ptset.Int.cardinal labels in
if c == 0 then _nop
- else if c == 1 then tagged_many s (Ptset.Int.choose labels)
- else if c > 5 then if has_text labels then any s else any_notext s
- else select_many s labels
+ else
+ let not_t = Ptset.Int.diff l_many labels in
+ let () =
+ LOG(__ "level2-jit" 3 "Would jump for tag %s to labels %a, not relevant tags: %a"
+ (Tag.to_string tag)
+ TagSet.print (TagSet.inj_positive labels)
+ TagSet.print (TagSet.inj_positive not_t))
+ in
+ if Ptset.Int.subset not_t not_elements then
+ if has_text labels then any s else any_notext s
+ else if c == 1 then tagged_many s (Ptset.Int.choose labels)
+ else
+ if c >= 5 then
+ if has_text labels then any s else any_notext s
+ 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 assert false
| _ -> assert false
+let count = ref 0
+let () = at_exit (fun () -> Logger.verbose Format.err_formatter "Compute jump called %i times\n" !count)
+module Memo = Hashtbl.Make(struct
+ type t = Tag.t * StateSet.t * dir
+ let equal (a,b,c) (d,e,f) = a == d && b == e && c == f
+ let hash (a, b, c) = HASHINT3(a, Uid.to_int b.StateSet.Node.id, (Obj.magic c))
+end)
+
+let memo = Memo.create 1024
+let init () = Memo.clear memo
+
let compute_jump auto tree tag states dir =
- if !Options.no_jump then
+ if !Config.no_jump then
if dir == DIR_LEFT then FIRST_CHILD states
else NEXT_SIBLING states
else
- let jkind = Ata.top_down_approx auto states tree in
- let jump = translate_jump tree tag jkind dir states in
- LOG("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
+ try
+ Memo.find memo (tag, states, dir)
+ with
+ Not_found -> begin
+ incr count;
+ let jkind = Ata.top_down_approx auto states tree in
+ let jump = translate_jump tree tag jkind dir states in
+ LOG(__ "level2-jit" 2
+ "Computed jumps for %s %a %s, from %a : %a%!"
+ (Tag.to_string tag)
+ StateSet.print states
+ (if dir == DIR_LEFT then "left" else "right")
+ Ata.print_kind jkind
+ print_jump jump
+ );
+ Memo.add memo (tag, states, dir) jump; jump
+ end
let compile cache2 auto tree tag states =
let tr_list, states1, states2 =
- Ata.get_trans ~attributes:(TagSet.inj_positive (Tree.attribute_tags tree)) auto states tag
+ Ata.get_trans (*~attributes:(TagSet.inj_positive (Tree.attribute_tags tree))*) auto states tag
in
let op =
let empty_s1 = StateSet.is_empty states1 in
let empty_s2 = StateSet.is_empty states2 in
- if empty_s1 && empty_s2 then RETURN
+ if empty_s1 && empty_s2 then return
else if empty_s1 then
RIGHT (tr_list,
compute_jump auto tree tag states2 DIR_RIGHT)
| BOTH(tr, NOP _, r) -> RIGHT (tr, r)
| _ -> op
in
- add cache2 tag states op;
+ if not !Config.no_cache then add cache2 tag states op;
op
let get_transitions = function
- | CACHE | RETURN -> failwith "get_transitions"
+ | CACHE _ | RETURN _ -> failwith "get_transitions"
| LEFT (tr, _)
| RIGHT (tr, _)
| BOTH (tr, _, _) -> tr
projects / SXSI / xpathcomp.git / blobdiff