IFNDEF TRACE__ML__
THEN
DEFINE TRACE__ML__
-
+module Loc = Camlp4.PreCast.Loc
let __ x =
ignore (Format.flush_str_formatter());
Format.kfprintf
return (Val_int(XMLTREE(tree)->NextElement(TREENODEVAL(node))));
}
+NoAlloc extern "C" value caml_xml_tree_next_node_before(value tree, value node, value ctx){
+ return (Val_int(XMLTREE(tree)->NextNodeBefore(TREENODEVAL(node), TREENODEVAL(ctx))));
+}
+
NoAlloc extern "C" value caml_xml_tree_prev_sibling(value tree, value node){
return (Val_int(XMLTREE(tree)->PrevSibling(TREENODEVAL(node))));
}
INCLUDE "debug.ml"
INCLUDE "utils.ml"
+INCLUDE "trace.ml"
open Format
| [ (_, (l, r, _) ) ] when l == StateSet.empty -> JUMP_ONE(rel_labels)
| _ ->
- if Ptset.Int.mem Tag.pcdata rel_labels then
- let () =
- D_TRACE_(Format.eprintf ">>> Computed rel_labels: %a\n%!"
- TagSet.print (TagSet.inj_positive rel_labels))
- in NODE
- else STAR
+ if Ptset.Int.mem Tag.pcdata rel_labels then begin
+ TRACE("top-down-approx", 3, __ "Computed rel_labels: %a\n"
+ TagSet.print
+ (TagSet.inj_positive rel_labels));
+ NODE
+ end else STAR
module Cache = Hashtbl.Make(StateSet)
let cache = Cache.create 1023
merge_trans by_states merge_labels
(List.sort by_states uniq_states_trs)
in
- D_TRACE_(
- let is_pairwise_disjoint l =
- List.for_all (fun ((ts, _) as tr) ->
- List.for_all (fun ((ts', _) as tr') ->
- (ts == ts' && (by_states tr tr' == 0)) ||
- TagSet.is_empty (TagSet.cap ts ts')) l) l
- in
- let is_complete l = TagSet.positive
- (List.fold_left (fun acc (ts, _) -> TagSet.cup acc ts)
- TagSet.empty l)
- ==
- (Tree.node_tags tree)
- in
- eprintf "Top-down approximation (%b, %b):\n%!"
- (is_pairwise_disjoint td_approx)
- (is_complete td_approx);
- List.iter (fun (ts,(l,r, m)) ->
- let ts = if TagSet.cardinal ts >10
- then TagSet.diff TagSet.any
- (TagSet.diff
- (TagSet.inj_positive (Tree.node_tags tree))
- ts)
- else ts
- in
- eprintf "%a, %a, %b -> %a, %a\n%!"
- StateSet.print states
- TagSet.print ts
- m
- StateSet.print l
- StateSet.print r
- ) td_approx;
- eprintf "\n%!"
-
+ TRACE(
+ "top-down-approx", 2,
+ let is_pairwise_disjoint l =
+ List.for_all (fun ((ts, _) as tr) ->
+ List.for_all (fun ((ts', _) as tr') ->
+ (ts == ts' && (by_states tr tr' == 0)) ||
+ TagSet.is_empty (TagSet.cap ts ts')) l) l
+ in
+ let is_complete l = TagSet.positive
+ (List.fold_left (fun acc (ts, _) -> TagSet.cup acc ts)
+ TagSet.empty l)
+ ==
+ (Tree.node_tags tree)
+ in
+ let pr_td_approx fmt td_approx =
+ List.iter (fun (ts,(l,r, m)) ->
+ let ts = if TagSet.cardinal ts >10
+ then TagSet.diff TagSet.any
+ (TagSet.diff
+ (TagSet.inj_positive (Tree.node_tags tree))
+ ts)
+ else ts
+ in
+ fprintf fmt "\t%a, %a, %b -> %a, %a\n%!"
+ StateSet.print states
+ TagSet.print ts
+ m
+ StateSet.print l
+ StateSet.print r
+ ) td_approx;
+ fprintf fmt "\n%!"
+ in
+ __ " pairwise-disjoint:%b, complete:%b:\n%a"
+ (is_pairwise_disjoint td_approx)
+ (is_complete td_approx)
+ pr_td_approx td_approx
);
let jump =
compute_jump
(List.exists (fun (_,(_,_,b)) -> b) td_approx)
in
Cache.add cache states jump; jump
-
INCLUDE "debug.ml"
INCLUDE "utils.ml"
+INCLUDE "trace.ml"
open Format
open Ata
let labels = Ptset.Int.inter l_one t in
let c = Ptset.Int.cardinal labels in
if c == 0 then _nop
- 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 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 if c > 5 then if has_text labels then any s else any_notext s
else select_one s labels
| _ -> assert false
let compute_jump auto tree tag states dir =
- (*PROF_CFUN("L2JIT.compute_jump"); *)
if !Options.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
- D_TRACE_(eprintf "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
+ 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
let compile cache2 auto tree tag states =
- (*PROF_CFUN("L2JIT.compile"); *)
let tr_list, states1, states2 =
StateSet.fold
(fun q acc ->
LEFT (tr_list,
compute_jump auto tree tag states1 DIR_LEFT)
else
- BOTH (tr_list,
- compute_jump auto tree tag states1 DIR_LEFT,
- compute_jump auto tree tag states2 DIR_RIGHT)
+ 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() *)
INCLUDE "debug.ml"
INCLUDE "utils.ml"
+INCLUDE "trace.ml"
+
open Format
type instr =
;;
*)
-DEFINE SET(a, b) = a <- b
+DEFINE SET(a, b) = (a) <- (b)
DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
match inst with
| OP_NOP _ -> ()
| OP_LEFT1 src ->
- if slot != slot1 then SET(slot.(dst), slot1.(src))
+ SET(slot.(dst), slot1.(src))
| OP_LEFT2 (src1, src2) ->
SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
- | OP_RIGHT1 src -> if slot != slot2 then SET(slot.(dst) , slot2.(src))
+ | OP_RIGHT1 src -> SET(slot.(dst) , slot2.(src))
| OP_RIGHT2 (src1, src2) ->
SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
| OP_LEFT1_RIGHT2 (src1, src2, src3) ->
- SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3))
+ TRACE("res-jit", 3, __ "slot==slot1: %b, slot==slot2:%b\n" (slot==slot1) (slot==slot2));
+ SET (slot.(dst) , ns.concat3 slot1.(src1) slot2.(src2) slot2.(src3));
| OP_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
SET (slot.(dst) , ns.concat4 slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4))
struct
module NS = NodeSet.Count
type t = NodeSet.Count.t array
+ let pr_slot fmt s =
+ let pr fmt (state, count) =
+ fprintf fmt "%a: %i" State.print state (NS.length count)
+ in
+ Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
let rec exec slot slot1 slot2 t code =
match code with
| Nil -> ()
- | Cons(dst, code, code1) ->
- exec_code slot slot1 slot2 t dst code;
- begin
- match code1 with
- | Nil -> ()
- | Cons(dst, code, code1) ->
- exec_code slot slot1 slot2 t dst code;
- exec slot slot1 slot2 t code1
- end
+ | Cons(dst, opcode, code1) ->
+ TRACE("res-jit", 3, __ " %a := %a\n%!"
+ State.print dst print_opcode opcode;
+ );
+ exec_code slot slot1 slot2 t dst opcode;
+ begin
+ match code1 with
+ | Nil -> ()
+ | Cons(dst, opcode, code1) ->
+ TRACE("res-jit", 3, __ " %a := %a\n%!"
+ State.print dst print_opcode opcode;
+ );
+ exec_code slot slot1 slot2 t dst opcode;
+ exec slot slot1 slot2 t code1
+ end
+
+ let exec slot slot1 slot2 t code =
+ TRACE("res-jit", 3, __ "Node %i:\n" (Node.to_int t));
+ TRACE("res-jit", 3, __ " LEFT : %a\n" pr_slot slot1);
+ TRACE("res-jit", 3, __ " RIGHT : %a\n" pr_slot slot2);
+ exec slot slot1 slot2 t code;
+ TRACE("res-jit", 3, __ " RES : %a\n\n%!" pr_slot slot)
+
end
module Mat =
struct
module NS = NodeSet.Mat
type t = NodeSet.Mat.t array
+ let pr_slot fmt s =
+ let pr fmt (state, count) =
+ fprintf fmt "%a: %i" State.print state (NS.length count)
+ in
+ Pretty.print_array ~sep:", " pr fmt (Array.mapi (fun x y -> (x,y)) s)
let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
exec_code slot slot1 slot2 t dst code;
begin
match code1 with
- | Nil -> ()
- | Cons(dst, code, code1) ->
- exec_code slot slot1 slot2 t dst code;
- exec slot slot1 slot2 t code1
+ | Nil -> ()
+ | Cons(dst', code', code1') ->
+ exec_code slot slot1 slot2 t dst' code';
+ exec slot slot1 slot2 t code1'
end
end
Translist.fold (fun t (a1, a2) ->
let _, _, _, f = Transition.node t in
let (_, _, fs1), (_, _, fs2) = Formula.st f in
- (StateSet.union s1 fs1, StateSet.union s2 fs2)
+ (StateSet.union a1 fs1, StateSet.union a2 fs2)
) trl (StateSet.empty, StateSet.empty)
in
let ns1 = StateSet.inter s1 orig_s1
DEFINE LOOP (t, states, ctx) = (
let _t = (t) in
TRACE("top-down-run", 3,
- __ "Entering node %i (tag %s, context %i) with states %a\n%!"
+ __ "Entering node %i with loop (tag %s, context %i) with states %a\n%!"
(Node.to_int _t)
(Tag.to_string (Tree.tag tree _t))
(Node.to_int (ctx))
DEFINE LOOP_TAG (t, states, tag, ctx) = (
let _t = (t) in (* to avoid duplicating expression t *)
+ TRACE("top-down-run", 3,
+ __ "Entering node %i with loop_tag (tag %s, context %i) with states %a\n%!"
+ (Node.to_int _t)
+ (Tag.to_string (tag))
+ (Node.to_int (ctx))
+ (StateSet.print) (states));
if _t == Tree.nil then nil_res
else
l2jit_dispatch
match instr with
| L2JIT.NOP () -> nil_res
| L2JIT.FIRST_CHILD s -> LOOP ((Tree.first_child tree t), s, ctx)
- | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_sibling tree t), s, ctx)
+(* | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_sibling tree t), s, ctx) *)
+ | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_node_before tree t ctx), s, ctx)
| L2JIT.FIRST_ELEMENT s -> LOOP ((Tree.first_element tree t), s, ctx)
- | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_element tree t), s, ctx)
+(* | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_element tree t), s, ctx) *)
+ | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_node_before tree t ctx), s, ctx)
| L2JIT.TAGGED_DESCENDANT (s, tag) ->
LOOP_TAG ((Tree.tagged_descendant tree t tag), s, tag, ctx)
type tracer = string
type level = int
-let tracers = [ "top-down-run"; "top-down-approx"; "result-set" ]
+let tracers = [ "top-down-run"; "top-down-approx"; "result-set"; "level2-jit"; "res-jit" ]
let active_tracers : (tracer, int) Hashtbl.t = Hashtbl.create 17
let available () = tracers
if l <= level t
then begin
fprintf !tracer_output "%s: " t;
- fprintf !tracer_output "%s" s
+ fprintf !tracer_output "%s%!" s
end
external tree_next_element : tree -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_element" "noalloc"
let next_element t n = tree_next_element t.doc n
+external tree_next_node_before : tree -> [`Tree] Node.t -> [`Tree] Node.t -> [`Tree] Node.t = "caml_xml_tree_next_node_before" "noalloc"
+let next_node_before t n ctx = tree_next_node_before t.doc n ctx
+
external tree_tagged_following_sibling : tree -> [`Tree] Node.t -> Tag.t -> [`Tree] Node.t = "caml_xml_tree_tagged_following_sibling" "noalloc"
let tagged_following_sibling t n tag = tree_tagged_following_sibling t.doc n tag
val next_sibling : t -> node -> node
val prev_sibling : t -> node -> node
val next_element : t -> node -> node
+val next_node_before : t -> node -> node -> node
val tagged_following_sibling : t -> node -> Tag.t -> node
val select_following_sibling : t -> node -> unordered_set -> node
projects / SXSI / xpathcomp.git / commitdiff