From ff99aa3de1810d5607f31f1f7597da78af72b6bf Mon Sep 17 00:00:00 2001 From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= Date: Thu, 15 Mar 2012 16:07:01 +0100 Subject: [PATCH] Defunctorize the ResJIT module. --- src/main.ml | 19 ++++++-- src/resJIT.ml | 49 +++++++++++++++++---- src/resJIT.mli | 7 +++ src/runtime.ml | 112 +++++++++++++++++++++++++++++++++++++++++++++++- src/runtime.mli | 9 ++++ 5 files changed, 183 insertions(+), 13 deletions(-) diff --git a/src/main.ml b/src/main.ml index 42c8822..128ac53 100644 --- a/src/main.ml +++ b/src/main.ml @@ -76,13 +76,24 @@ let main v query_string output = if !Options.count_only then let module R = ResJIT.Count in - let module M = Runtime.Make(R) in (* mk_runtime run auto doc arg count print outfile *) - mk_runtime M.top_down_run auto v Tree.root R.NS.length R.NS.serialize None + mk_runtime (Runtime.top_down_run { + Runtime.empty = R.NS.empty; + Runtime.subtree_tags = R.NS.subtree_tags; + Runtime.subtree_elements = R.NS.subtree_elements; + Runtime.exec = ResJIT.count_exec; + }) + auto v Tree.root R.NS.length R.NS.serialize None else let module R = ResJIT.Mat in - let module M = Runtime.Make(R) in - mk_runtime M.top_down_run auto v Tree.root R.NS.length R.NS.serialize !Options.output_file + mk_runtime + (Runtime.top_down_run { + Runtime.empty = R.NS.empty; + Runtime.subtree_tags = R.NS.subtree_tags; + Runtime.subtree_elements = R.NS.subtree_elements; + Runtime.exec = ResJIT.mat_exec; + }) + auto v Tree.root R.NS.length R.NS.serialize !Options.output_file in runtime () ;; diff --git a/src/resJIT.ml b/src/resJIT.ml index c3daf11..e7189f5 100644 --- a/src/resJIT.ml +++ b/src/resJIT.ml @@ -346,8 +346,8 @@ DEFINE EXEC_INSTR_TEMPLATE(ns) = fun slot1 slot2 t inst acc -> | 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 -> @@ -398,16 +398,19 @@ DEFINE EXEC_CODE_TEMPLATE(ns) = fun slot slot1 slot2 t dst code -> | 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 = +DEFINE EXEC_REC_TEMPLATE(exec_code) = (match code with | Nil -> () | Cons(dst, opcode, code1) -> @@ -426,6 +429,26 @@ DEFINE EXEC_REC_TEMPLATE = 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)); @@ -445,6 +468,16 @@ DEFINE UPDATE_TEMPLATE = 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 = sig module NS : NodeSet.S @@ -465,7 +498,7 @@ module Count = let print fmt s = PRINT_TEMPLATE(NS) let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Count) let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Count) - let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE + 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 @@ -480,7 +513,7 @@ module Mat = let print fmt s = PRINT_TEMPLATE(NS) let exec_instr = EXEC_INSTR_TEMPLATE(NodeSet.Mat) let exec_code = EXEC_CODE_TEMPLATE(NodeSet.Mat) - let rec exec slot slot1 slot2 t code = EXEC_REC_TEMPLATE + 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 @@ -497,7 +530,7 @@ module Make(U : NodeSet.S) = 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 + 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 = diff --git a/src/resJIT.mli b/src/resJIT.mli index a870bc0..6822b0b 100644 --- a/src/resJIT.mli +++ b/src/resJIT.mli @@ -31,6 +31,13 @@ type 'a update = 'a -> 'a -> 'a -> Tree.t -> Tree.node -> StateSet.t * 'a type 'a cache = 'a update Cache.Lvl3.t val dummy_update : 'a update val create : unit -> 'a cache +val update : + ('a array -> 'a array -> 'a array -> Tree.node -> code -> unit) -> + 'a array cache -> Ata.t -> Translist.t -> StateSet.t -> StateSet.t -> + 'a array -> 'a array -> 'a array -> Tree.t -> Tree.node -> StateSet.t * 'a array + +val count_exec : NodeSet.Count.t array -> NodeSet.Count.t array -> NodeSet.Count.t array -> Tree.node -> code -> unit +val mat_exec : NodeSet.Mat.t array -> NodeSet.Mat.t array -> NodeSet.Mat.t array -> Tree.node -> code -> unit module type S = sig diff --git a/src/runtime.ml b/src/runtime.ml index 5ca556b..498a1dc 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -217,7 +217,7 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( in *) let l3jit_dispatch trl s1 s2 t sl1 sl2 = - U.update cache3 auto trl s1 s2 empty_slot sl1 sl2 tree t + ResJIT.update U.exec cache3 auto trl s1 s2 empty_slot sl1 sl2 tree t in let cache2 = L2JIT.create () in @@ -648,3 +648,113 @@ let dispatch_param1 conf id2 y0 y1 = end + +type 'a result_ops = { + empty : 'a; + subtree_tags : Tree.t -> Tree.node -> Tag.t -> 'a; + subtree_elements : Tree.t -> Tree.node -> 'a; + exec : 'a array -> 'a array -> 'a array -> Tree.node -> ResJIT.code -> unit; +} + +let top_down_run rs auto tree root states ctx = + let res_len = StateSet.max_elt auto.states + 1 in + let empty_slot = Array.create res_len rs.empty in + let nil_res = auto.bottom_states, empty_slot in + let cache3 = ResJIT.create () in + let mark_subtree s subtree = + if subtree != rs.empty then + let r = Array.copy empty_slot in + r.(auto.last) <- subtree; + s,r + else + s,empty_slot + in + (* let l3jit_dispatch trl s1 s2 t sl1 sl2 = + let f = L3JIT.find cache3 trl s1 s2 in + if f == l3jit_dummy then + + (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t + else f empty_slot sl1 sl2 tree t + + in *) + let l3jit_dispatch trl s1 s2 t sl1 sl2 = + ResJIT.update rs.exec cache3 auto trl s1 s2 empty_slot sl1 sl2 tree t + in + let cache2 = L2JIT.create () in + + let rec l2jit_dispatch t tag states ctx opcode = + match opcode with + | L2JIT.RETURN -> nil_res + | L2JIT.CACHE -> + let opcode = L2JIT.compile cache2 auto tree tag states in + l2jit_dispatch t tag states ctx opcode + + | L2JIT.LEFT (tr_list, instr) -> + let res1, slot1 = + l2jit_dispatch_instr t (Tree.closing tree t) instr + in + l3jit_dispatch tr_list res1 auto.bottom_states t slot1 empty_slot + + | L2JIT.RIGHT (tr_list, instr) -> + let res2, slot2 = + l2jit_dispatch_instr t ctx instr + in + l3jit_dispatch tr_list auto.bottom_states res2 t empty_slot slot2 + + | L2JIT.BOTH (tr_list, instr1, instr2) -> + let res1, slot1 = + l2jit_dispatch_instr t (Tree.closing tree t) instr1 + in + let res2, slot2 = + l2jit_dispatch_instr t ctx instr2 + in + l3jit_dispatch tr_list res1 res2 t slot1 slot2 + + and l2jit_dispatch_instr t ctx instr = + match instr with + | 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.FIRST_ELEMENT s -> LOOP ((Tree.first_element tree t), s, ctx) + | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_element tree t), s, ctx) + + | L2JIT.TAGGED_DESCENDANT (s, tag) -> + LOOP_TAG ((Tree.tagged_descendant tree t tag), s, tag, ctx) + + | L2JIT.TAGGED_FOLLOWING (s, tag) -> + LOOP_TAG((Tree.tagged_following_before tree t tag ctx), s, tag, ctx) + + | L2JIT.SELECT_DESCENDANT (s, _, us) -> + LOOP((Tree.select_descendant tree t us), s, ctx) + + | L2JIT.SELECT_FOLLOWING (s, pt, us) -> + LOOP ((Tree.select_following_before tree t us ctx), s, ctx) + + | L2JIT.TAGGED_CHILD (s, tag) -> + LOOP_TAG((Tree.tagged_child tree t tag), s, tag, ctx) + + | L2JIT.TAGGED_FOLLOWING_SIBLING (s, tag) -> + LOOP_TAG((Tree.tagged_following_sibling tree t tag), s, tag, ctx) + + | L2JIT.SELECT_CHILD (s, _, us) -> + LOOP ((Tree.select_child tree t us), s, ctx) + + | L2JIT.SELECT_FOLLOWING_SIBLING (s, _, us) -> + LOOP ((Tree.select_following_sibling tree t us), s, ctx) + + | L2JIT.TAGGED_SUBTREE(s, tag) -> + mark_subtree s (rs.subtree_tags tree t tag) + + | L2JIT.ELEMENT_SUBTREE(s) -> + mark_subtree s (rs.subtree_elements tree t) + in + let r = LOOP (root, states, ctx) in + (*L3JIT.stats err_formatter cache3; *) + r + +let full_top_down_run rs auto states tree root = + top_down_run rs auto tree root states (Tree.closing tree root) + +let top_down_run rs auto tree root = + let res, slot = full_top_down_run rs auto auto.init tree root in + slot.(StateSet.min_elt auto.topdown_marking_states) diff --git a/src/runtime.mli b/src/runtime.mli index 0ce04ef..fd36d23 100644 --- a/src/runtime.mli +++ b/src/runtime.mli @@ -6,3 +6,12 @@ module type S = sig end module Make (U : ResJIT.S) : S with type result_set = U.NS.t + +type 'a result_ops = { + empty : 'a; + subtree_tags : Tree.t -> Tree.node -> Tag.t -> 'a; + subtree_elements : Tree.t -> Tree.node -> 'a; + exec : 'a array -> 'a array -> 'a array -> Tree.node -> ResJIT.code -> unit; +} + +val top_down_run : 'a result_ops -> Ata.t -> Tree.t -> Tree.node -> 'a -- 2.17.1