let l = List.filter (fun (_, instr) -> instr <> OP_NOP ()) l in
to_list l, not marking
-(*
-let _total = ref 0
-let _empty = ref 0
-let () = at_exit (fun () -> Printf.eprintf "Dummy affectations %i/%i\n%!" !_empty !_total)
-;;
-*)
+
+type 'a update = 'a -> 'a -> 'a -> Tree.t -> Tree.node -> StateSet.t * 'a
+type 'a cache = 'a update Cache.Lvl3.t
+
+let dummy_update = fun _ _ _ _ _ -> failwith "Uninitialized L3JIT"
+let show_stats (a : 'a cache) =
+ let count = ref 0 in
+ Cache.Lvl3.iteri (fun _ _ _ _ b -> if not b then incr count) a;
+ eprintf "%!L3JIT: %i used entries\n%!" !count
+
+let create () =
+ let v = Cache.Lvl3.create 1024 dummy_update in
+ if !Options.verbose then at_exit (fun () -> show_stats v);
+ v
+
+let find (t : 'a cache) tlist s1 s2 =
+ Cache.Lvl3.find t
+ (Uid.to_int s2.StateSet.Node.id)
+ (Uid.to_int s1.StateSet.Node.id)
+ (Uid.to_int tlist.Translist.Node.id)
+
+let add (t : 'a cache) tlist s1 s2 v =
+ Cache.Lvl3.add t
+ (Uid.to_int s2.StateSet.Node.id)
+ (Uid.to_int s1.StateSet.Node.id)
+ (Uid.to_int tlist.Translist.Node.id)
+ v
+
+let eval_form auto s1 s2 f =
+ let rec loop f =
+ match Formula.expr f with
+ | Formula.False | Formula.True | Formula.Pred _ -> f, []
+ | Formula.Atom(`Left, b, q) ->
+ Formula.of_bool (b == (StateSet.mem q s1)),
+ if b && StateSet.mem q auto.Ata.topdown_marking_states then [LEFT q] else []
+ | Formula.Atom (`Right, b, q) ->
+ Formula.of_bool(b == (StateSet.mem q s2)),
+ if b && StateSet.mem q auto.Ata.topdown_marking_states then [RIGHT q] else []
+ | Formula.Atom (`Epsilon, _, _) -> assert false
+
+ | Formula.Or(f1, f2) ->
+ let b1, i1 = loop f1 in
+ let b2, i2 = loop f2 in
+ Formula.or_pred b1 b2, i1 @ i2
+ | Formula.And(f1, f2) ->
+ let b1, i1 = loop f1 in
+ let b2, i2 = loop f2 in
+ Formula.and_pred b1 b2, i1 @ i2
+ in
+ loop f
+
+let eval_trans auto s1 s2 trans =
+ Translist.fold
+ (fun t ((a_st, a_op, a_todo) as acc)->
+ let q, _, m, f = Transition.node t in
+ let form, ops = eval_form auto s1 s2 f in
+ match Formula.expr form with
+ | Formula.True ->
+ StateSet.add q a_st,
+ (q, (if m then (SELF() :: ops) else ops)):: a_op,
+ a_todo
+ | Formula.False -> acc
+ | Formula.Pred p -> a_st, a_op,
+ (p.Tree.Predicate.node, q, [(q,(if m then (SELF() :: ops) else ops))]) :: a_todo
+ | _ -> assert false
+ ) trans (StateSet.empty, [], [])
+
+let compile_update auto trl s1 s2 =
+ let orig_s1, orig_s2 =
+ Translist.fold (fun t (a1, a2) ->
+ let _, _, _, f = Transition.node t in
+ let fs1, fs2 = Formula.st f in
+ (StateSet.union a1 fs1, StateSet.union a2 fs2)
+ ) trl (StateSet.empty, StateSet.empty)
+ in
+ let ns1 = StateSet.inter s1 orig_s1
+ and ns2 = StateSet.inter s2 orig_s2 in
+ let res, ops, todo = eval_trans auto ns1 ns2 trl in
+ let code, not_marking = compile ops in
+ let todo_code, todo_notmarking =
+ List.fold_left (fun (l, b) (p, q, o) -> let c, b' = compile o in
+ (p, q, c)::l, b && b')
+ ([], not_marking) todo
+ in
+ let opcode = res, code, todo_notmarking, todo_code in
+ opcode
+
+let gen_code exec auto tlist s1 s2 =
+ let res, code, not_marking, todo_code = compile_update auto tlist s1 s2 in
+ let f =
+ if todo_code == [] then
+ if not_marking then begin fun empty_slot sl1 sl2 _ node ->
+ let slot1_empty = sl1 == empty_slot
+ and slot2_empty = sl2 == empty_slot in
+ if slot1_empty && slot2_empty then res,sl2
+ else
+ let sl =
+ if slot2_empty then
+ if slot1_empty then
+ Array.copy empty_slot
+ else sl1
+ else sl2
+ in
+ exec sl sl1 sl2 node code;
+ res, sl
+ end
+ else (* marking *) begin fun empty_slot sl1 sl2 _ node ->
+ let sl =
+ if sl2 == empty_slot then
+ if sl1 == empty_slot then
+ Array.copy empty_slot
+ else sl1
+ else sl2
+ in
+ exec sl sl1 sl2 node code;
+ res, sl
+ end
+ else (* todo != [] *)
+ begin fun empty_slot sl1 sl2 tree node ->
+ let sl =
+ if sl2 == empty_slot then
+ if sl1 == empty_slot then
+ Array.copy empty_slot
+ else sl1
+ else sl2
+ in
+ exec sl sl1 sl2 node code;
+ List.fold_left
+ (fun ares (p, q, code) ->
+ if !p tree node then begin
+ if code != Nil then exec sl sl1 sl2 node code;
+ StateSet.add q ares
+ end
+ else ares) res todo_code, sl
+
+ end
+ in
+ f
+
+
+
+
DEFINE SET(a, b) = (a) <- (b)
+DEFINE PRINT_TEMPLATE(ns) =
+ 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)
+
DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc ->
match inst with
| SELF _ -> ns.snoc acc t
| RIGHT src -> ns.concat acc slot2.(src)
-DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
- match code with
+DEFINE EXEC_CODE_BODY_TEMPLATE(ns) =
+ (match code with
| OP_NOP _ -> ()
| OP_LEFT1 src ->
- SET(slot.(dst), slot1.(src))
+ SET(slot.(dst), slot1.(src))
| OP_LEFT2 (src1, src2) ->
- SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
+ SET(slot.(dst) , ns.concat slot1.(src1) slot1.(src2))
| OP_RIGHT1 src -> SET(slot.(dst) , slot2.(src))
SET (slot.(dst) , ns.concat slot2.(src1) slot2.(src2) )
| OP_LEFT1_RIGHT1 (src1, src2) ->
- SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
+ SET (slot.(dst) , ns.concat slot1.(src1) slot2.(src2))
| OP_LEFT2_RIGHT1 (src1, src2, src3) ->
- SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
+ SET (slot.(dst) , ns.concat3 slot1.(src1) slot1.(src2) slot2.(src3))
| OP_LEFT1_RIGHT2 (src1, src2, 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) ->
| OP_SELF_LEFT2_RIGHT2 (src1, src2, src3, src4) ->
slot.(dst) <-
ns.conscat4 t slot1.(src1) slot1.(src2) slot2.(src3) slot2.(src4)
- | OP_OTHER line ->
+ | OP_OTHER line -> assert false (*
let acc = ref ns.empty in
let len = Array.length line - 1 in
for j = 0 to len do
acc := exec_instr slot1 slot2 t line.(j) !acc
done;
- slot.(dst) <- !acc
+ slot.(dst) <- !acc *) )
+
+DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code ->
+ EXEC_CODE_BODY_TEMPLATE(ns)
+
+
+DEFINE EXEC_REC_TEMPLATE(exec_code) =
+ (match code 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;
+ 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 count_exec_code slot slot1 slot2 t dst code =
+ EXEC_CODE_BODY_TEMPLATE(NodeSet.Count)
+
+
+let count_exec slot slot1 slot2 t code =
+ let rec exec slot slot1 slot2 t code =
+ EXEC_REC_TEMPLATE(count_exec_code)
+ in
+ exec slot slot1 slot2 t code
+
+let mat_exec_code slot slot1 slot2 t dst code =
+ EXEC_CODE_BODY_TEMPLATE(NodeSet.Mat)
+
+
+let mat_exec slot slot1 slot2 t code =
+ let rec exec slot slot1 slot2 t code =
+ EXEC_REC_TEMPLATE(mat_exec_code)
+ in
+ exec slot slot1 slot2 t code
+
+
+DEFINE EXEC_TEMPLATE =
+ (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))
+
+
+DEFINE UPDATE_TEMPLATE =
+ let f = find cache tlist s1 s2 in
+ if f == dummy_update then
+ let f = gen_code exec auto tlist s1 s2 in
+ add cache tlist s1 s2 f;
+ f empty_res sl1 sl2 tree node
+ else
+ f empty_res sl1 sl2 tree node
+
+
+let update exec cache auto tlist s1 s2 empty_res sl1 sl2 tree node =
+ let f = find cache tlist s1 s2 in
+ if f == dummy_update then
+ let f = gen_code exec auto tlist s1 s2 in
+ add cache tlist s1 s2 f;
+ f empty_res sl1 sl2 tree node
+ else
+ f empty_res sl1 sl2 tree node
module type S =
module NS : NodeSet.S
type t = NS.t array
val exec : t -> t -> t -> Tree.node -> code -> unit
+ val update : t cache -> Ata.t -> Translist.t -> StateSet.t -> StateSet.t ->
+ t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t
+ val print : Format.formatter -> t -> unit
+ val var : int -> t -> t
+ val close : ((int*State.t, NS.t) Hashtbl.t) -> t -> t
+ val is_open : t -> bool
end
-
-
module Count =
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 print fmt s = PRINT_TEMPLATE(NS)
let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count)
let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count)
- (* inline by hand for efficiency reason *)
- let rec exec slot slot1 slot2 t code =
- match code 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;
- 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)
-
+ let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE(exec_code)
+ let exec slot slot1 slot2 t code = EXEC_TEMPLATE
+ let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
+ let var _ x = x
+ let close _ x = x
+ let is_open _ = false
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 print fmt s = PRINT_TEMPLATE(NS)
let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat)
let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat)
- (* inline by hand for efficiency reason *)
- 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
+ let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE(exec_code)
+ let exec slot slot1 slot2 t code = EXEC_TEMPLATE
+ let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
+ let var _ x = x
+ let close _ x = x
+ let is_open _ = false
end
+module Make(U : NodeSet.S) =
+ struct
+ module NS = U
+ type t = U.t array
+ let print fmt s = PRINT_TEMPLATE(NS)
+ let exec_instr = EXEC_INSTR_TEMPLATE(U)
+ let exec_code = EXEC_CODE_TEMPLATE(U)
+ let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE(exec_code)
+ let exec slot slot1 slot2 t code = EXEC_TEMPLATE
+ let update cache auto tlist s1 s2 empty_res sl1 sl2 tree node = UPDATE_TEMPLATE
+ let var i t =
+ Array.mapi (fun j _ -> NS.var (i,j)) t
+ let close h t =
+ Array.map (NS.close h) t
+
+ let is_open t =
+ List.exists NS.is_open (Array.to_list t)
+ end
projects / SXSI / xpathcomp.git / blobdiff