X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=src%2FresJIT.ml;h=c3daf11b13ca7b14c3fef08ffc97f9776bfc76da;hb=e5684525c6814acc412b582b346d5ee6cb5b6597;hp=64c96246116946d6f786b81bbed58b43e3a63e3b;hpb=d8e8a2b5c08a980a440d9fc9f3ea27af7711b524;p=SXSI%2Fxpathcomp.git diff --git a/src/resJIT.ml b/src/resJIT.ml index 64c9624..c3daf11 100644 --- a/src/resJIT.ml +++ b/src/resJIT.ml @@ -188,12 +188,148 @@ let compile l = 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) @@ -299,11 +435,23 @@ DEFINE EXEC_TEMPLATE = 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 + + module type S = sig 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 @@ -319,6 +467,7 @@ module Count = let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count) let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE 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 @@ -333,6 +482,7 @@ module Mat = let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat) let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE 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 @@ -349,6 +499,7 @@ module Make(U : NodeSet.S) = let exec_code = EXEC_CODE_TEMPLATE(U) let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE 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 =