From d7c0e0d3ae22f01c69f0352a25db3eaaab02406f Mon Sep 17 00:00:00 2001 From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= Date: Tue, 28 Feb 2012 15:33:10 +0100 Subject: [PATCH] Improve caching table: - uses the first used index as an offset. Allows to store compactly tables indexed by 10000, 10001, ... without storing the first 10000 that are never accessed. - resize automatically if lower offset is accessed Prevent caching overflow for large automata. --- src/cache.ml | 191 ++++++++++++------------- src/cache.mli | 21 +-- src/l2JIT.ml | 28 ++-- src/runtime.ml | 374 ++++++++++++++++++++++++++++--------------------- 4 files changed, 330 insertions(+), 284 deletions(-) diff --git a/src/cache.ml b/src/cache.ml index 71eb4fb..d65df68 100644 --- a/src/cache.ml +++ b/src/cache.ml @@ -2,120 +2,121 @@ INCLUDE "trace.ml" let realloc l old_size new_size dummy = let l' = Array.create new_size dummy in - Array.blit l 0 l' 0 (min old_size new_size); + for i = 0 to (min old_size new_size) - 1 do + l'.(i) <- l.(i); + done; l' module Lvl1 = struct - type 'a t = { mutable line : 'a array; - dummy : 'a } - - let create n a = { line = Array.create n a; - dummy = a } - - let find c i = - let line = c.line in - let len = Array.length line in - if i >= len then c.dummy else line.(i) - - let add c i v = - let line = c.line in - let len = Array.length line in - if i >= len then c.line <- realloc line len (i*2+1) c.dummy; - c.line.(i) <- v + dummy : 'a; + mutable offset : int; + } + let create n a = { + line = Array.create 0 a; + dummy = a; + offset = ~-1; + + } + + + let add a i v = + if a.offset == ~-1 then a.offset <- i; + let offset = a.offset in + let len = Array.length a.line in + if i >= offset && i < offset + len then + a.line.(i - offset) <- v + else + if i < offset then begin (* bottom resize *) + let pad = offset - i in + let nlen = len + pad in + let narray = Array.create nlen a.dummy in + for j = 0 to len - 1 do + narray.(j+pad) <- a.line.(j) + done; + a.offset <- i; + a.line <- narray; + narray.(0) <- v; + end else begin (* top resize *) + (* preventively allocate the space for the following elements *) + let nlen = ((i - offset + 1) lsl 1) + 1 in + let narray = Array.create nlen a.dummy in + for j = 0 to len - 1 do + narray.(j) <- a.line.(j); + done; + narray.(i - offset + 1) <- v; + a.line <- narray + end + + let find a i = + let offset = a.offset in + let len = Array.length a.line in + if i >= offset && i < offset + len then a.line.(i - offset) + else a.dummy - let dummy c = c.dummy + let dummy a = a.dummy - let to_array c = c.line end -include Lvl1 + module Lvl2 = struct - type 'a t = { mutable line : 'a array array; - dummy : 'a; - l1_size : int; - dummy_line1 : 'a array - } + type 'a t = 'a Lvl1.t Lvl1.t + let create n a = + let dummy1 = Lvl1.create 0 a in + { Lvl1.line = Array.create n dummy1; + Lvl1.offset = ~-1; + Lvl1.dummy = dummy1; + } - let dummy_line = [| |] - let create ?(l1_size=512) n a = - let dummy_line1 = Array.create l1_size a in - { line = Array.create n dummy_line1; - dummy = a; - l1_size = l1_size; - dummy_line1 = dummy_line1; - } + let add a i j v = + let line = Lvl1.find a i in + if line == a.Lvl1.dummy then + let nline = { line with Lvl1.offset = ~-1 } in + Lvl1.add nline j v; + Lvl1.add a i nline + else + Lvl1.add line j v + + let find a i j = + let v = Lvl1.find a i in + if v == a.Lvl1.dummy then a.Lvl1.dummy.Lvl1.dummy + else Lvl1.find v j + + + let dummy c = c.Lvl1.dummy.Lvl1.dummy - let find c i j = c.line.(i).(j) - - let add c i j v = - let line = c.line in - let len = Array.length line in - if i >= len then - c.line <- realloc line len (i*2 + 1) c.dummy_line1; - let line = c.line.(i) in - let line = - if line == c.dummy_line1 then - let nline = Array.copy line in - c.line.(i) <- nline; - nline - else line - in - line.(j) <- v - - let dummy c = c.dummy - let to_array c = c.line - let dummy_line c = c.dummy_line1 end module Lvl3 = struct - type 'a t = - { mutable line : 'a array array array; - dummy : 'a; - l1_size : int; - l2_size : int; - dummy_line1 : 'a array array; - dummy_line2 : 'a array } - - let dummy_line2 = [| |] - let dummy_line1 = [| |] - - let create ?(l1_size=512) ?(l2_size=512) n a = - let dummy_line2 = Array.create l2_size a in - let dummy_line1 = Array.create l1_size dummy_line2 in - { line = Array.create n dummy_line1; - dummy = a; - l1_size = l1_size; - l2_size = l2_size; - dummy_line1 = dummy_line1; - dummy_line2 = dummy_line2 + type 'a t = 'a Lvl2.t Lvl1.t + + let create n a = + let dummy1 = Lvl2.create 0 a in + { Lvl1.line = Array.create n dummy1; + Lvl1.offset = ~-1; + Lvl1.dummy = dummy1; } - let find t k j i = t.line.(i).(j).(k) - - - let add t k j i v = - let line = t.line in - let line1 = - let l1 = line.(i) in - if l1 == t.dummy_line1 then - let l1' = Array.copy l1 in - line.(i) <- l1'; l1' - else l1 - in - let line2 = - let l2 = line1.(j) in - if l2 == t.dummy_line2 then - let l2' = Array.copy l2 in - line1.(j) <- l2'; l2' - else l2 - in - line2.(k) <- v - let dummy a = a.dummy - let to_array a = a.line + let add a i j k v = + let line = Lvl1.find a i in + if line == a.Lvl1.dummy then + let nline = { line with Lvl1.offset = ~-1 } in + Lvl2.add nline j k v; + Lvl1.add a i nline + else + Lvl2.add line j k v + + let find a i j k = + let v = Lvl1.find a i in + if v == a.Lvl1.dummy then Lvl2.dummy a.Lvl1.dummy + else Lvl2.find v j k + + + let dummy a = Lvl2.dummy a.Lvl1.dummy + end diff --git a/src/cache.mli b/src/cache.mli index 2d52dc7..9057c10 100644 --- a/src/cache.mli +++ b/src/cache.mli @@ -1,12 +1,3 @@ -type 'a t - -val create : int -> 'a -> 'a t -val find : 'a t -> int -> 'a -val add : 'a t -> int -> 'a -> unit -val dummy : 'a t -> 'a -val to_array : 'a t -> 'a array - - module Lvl1 : sig @@ -16,21 +7,16 @@ sig val find : 'a t -> int -> 'a val add : 'a t -> int -> 'a -> unit val dummy : 'a t -> 'a - val to_array : 'a t -> 'a array end module Lvl2: sig - type 'a t - - val create : ?l1_size:int -> int -> 'a -> 'a t + val create : int -> 'a -> 'a t val find : 'a t -> int -> int -> 'a val add : 'a t -> int -> int -> 'a -> unit val dummy : 'a t -> 'a - val dummy_line : 'a t -> 'a array - val to_array : 'a t -> 'a array array end @@ -39,10 +25,9 @@ module Lvl3 : type 'a t - val create : ?l1_size:int -> ?l2_size:int -> int -> 'a -> 'a t + val create : int -> 'a -> 'a t val find : 'a t -> int -> int -> int -> 'a val add : 'a t -> int -> int -> int -> 'a -> unit val dummy : 'a t -> 'a - val to_array : 'a t -> 'a array array array - + end diff --git a/src/l2JIT.ml b/src/l2JIT.ml index 7a73d12..90be37f 100644 --- a/src/l2JIT.ml +++ b/src/l2JIT.ml @@ -86,21 +86,22 @@ let jump_stat_summary fmt = type opcode = - | CACHE of unit - | RETURN of unit + | CACHE + | RETURN | LEFT of Translist.t * jump | RIGHT of Translist.t * jump | BOTH of Translist.t * jump * jump type t = opcode Cache.Lvl2.t -let dummy = CACHE() + +let dummy = CACHE 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 - +(* let print_cache fmt d = let c = Cache.Lvl2.to_array d in Array.iteri begin fun tag a -> @@ -114,9 +115,9 @@ let print_cache fmt d = fprintf fmt "---------------------------\n%!" end end c - -let create () = Cache.Lvl2.create 1024 dummy - +*) +let create () = Cache.Lvl2.create 4096 dummy +(* let stats fmt c = let d = Cache.Lvl2.to_array c in let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in @@ -133,10 +134,11 @@ let stats fmt c = len lvl1 lvl2 (Ocaml.size_kb d); fprintf fmt "%s" "L2JIT Content:\n"; print_cache fmt c +*) -let find t tag set = Cache.Lvl2.find t tag (Uid.to_int set.StateSet.Node.id) +let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag -let add t tag set v = Cache.Lvl2.add t tag (Uid.to_int set.StateSet.Node.id) v +let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) = if TagSet.mem tag labels @@ -224,7 +226,7 @@ let compile cache2 auto tree tag states = 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) @@ -247,7 +249,7 @@ let compile cache2 auto tree tag states = op let get_transitions = function - | CACHE _ | RETURN _ -> failwith "get_transitions" + | CACHE | RETURN -> failwith "get_transitions" | LEFT (tr, _) | RIGHT (tr, _) | BOTH (tr, _, _) -> tr diff --git a/src/runtime.ml b/src/runtime.ml index 3bc3256..40c9e97 100644 --- a/src/runtime.ml +++ b/src/runtime.ml @@ -64,54 +64,24 @@ module Make (U : ResJIT.S) : S with type result_set = U.NS.t = type opcode = (t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t) - type t = opcode Cache.t Cache.t Cache.t + type t = opcode Cache.Lvl3.t let dummy _ _ _ _ _ = failwith "Uninitialized L3JIT" let create () = Cache.Lvl3.create 1024 dummy - - let stats fmt d = - let d = Cache.Lvl3.to_array d in - let len = Array.fold_left - (fun acc a -> - Array.fold_left (fun acc2 a2 -> Array.length a2 + acc2) acc a) 0 d - in - - let lvl1 = - Array.fold_left - (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in - let lvl2 = Array.fold_left - (fun acc a -> - Array.fold_left (fun acc2 a2 -> if Array.length a2 == 0 then acc2 else acc2+1) - acc a) 0 d - in - let lvl3 = Array.fold_left - (fun acc a -> - Array.fold_left (fun acc2 a2 -> - Array.fold_left - (fun acc3 a3 -> if a3 != dummy then acc3+1 else acc3) - acc2 a2) - acc a) 0 d - in - fprintf fmt "L3JIT Statistics: -\t%i entries -\t%i used L1 lines -\t%i used L2 lines -\t%i used L3 lines -\ttable size: %ikb\n" - len lvl1 lvl2 lvl3 (Ocaml.size_kb d) - let find t tlist s1 s2 = Cache.Lvl3.find t - (Uid.to_int tlist.Translist.Node.id) - (Uid.to_int s1.StateSet.Node.id) (Uid.to_int s2.StateSet.Node.id) + (Uid.to_int s1.StateSet.Node.id) + (Uid.to_int tlist.Translist.Node.id) + + let add t tlist s1 s2 v = Cache.Lvl3.add t - (Uid.to_int tlist.Translist.Node.id) - (Uid.to_int s1.StateSet.Node.id) (Uid.to_int s2.StateSet.Node.id) + (Uid.to_int s1.StateSet.Node.id) + (Uid.to_int tlist.Translist.Node.id) v let compile auto trl s1 s2 = @@ -221,8 +191,9 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( l2jit_dispatch _t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states))) + let top_down_run auto tree root states ctx = - let res_len = (StateSet.max_elt auto.states) + 1 in + let res_len = StateSet.max_elt auto.states + 1 in let empty_slot = Array.create res_len U.NS.empty in let nil_res = auto.bottom_states, empty_slot in let cache3 = L3JIT.create () in @@ -235,42 +206,39 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( in let cache2 = L2JIT.create () in - let () = D_TRACE_(at_exit (fun () -> L2JIT.stats Format.err_formatter cache2)) in let rec l2jit_dispatch t tag states ctx opcode = match opcode with - | L2JIT.RETURN () -> nil_res - | L2JIT.CACHE () -> + | 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 tag states (Tree.closing tree t) instr true + l2jit_dispatch_instr t tag states (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 tag states ctx instr false in + let res2, slot2 = l2jit_dispatch_instr t tag states 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 tag states (Tree.closing tree t) instr1 true + l2jit_dispatch_instr t tag states (Tree.closing tree t) instr1 in - let res2, slot2 = l2jit_dispatch_instr t tag states ctx instr2 false in + let res2, slot2 = l2jit_dispatch_instr t tag states ctx instr2 in l3jit_dispatch tr_list res1 res2 t slot1 slot2 - and l2jit_dispatch_instr t tag states ctx instr _left = + and l2jit_dispatch_instr t tag states ctx instr = 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_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_node_before tree t ctx), s, ctx) *) | L2JIT.TAGGED_DESCENDANT (s, tag) -> LOOP_TAG ((Tree.tagged_descendant tree t tag), s, tag, ctx) @@ -423,155 +391,245 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = ( let _, slot = loop_leaves leaves (nil_res) in slot.(StateSet.min_elt auto.topdown_marking_states) +let get_trans g auto tag states = + StateSet.fold (fun q tr_acc -> + List.fold_left + (fun ((lstates, rstates, tacc) as acc) (ts, trs) -> + if TagSet.mem (Tag.translate tag) ts then + if not (TagSet.mem Tag.attribute ts) && Grammar2.is_attribute g tag + then acc + else + let _, _, _, phi = Transition.node trs in + let (_,_,l), (_,_,r) = Formula.st phi in + (StateSet.union l lstates, + StateSet.union r rstates, + Translist.cons trs tacc) + else acc) + tr_acc (Hashtbl.find auto.trans q) + ) states (StateSet.empty, StateSet.empty, Translist.nil) (* Grammar run *) - - external is_young : 'a array -> bool = "caml_custom_is_young" "noalloc" - external blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_custom_array_blit" - module M = Map.Make(struct type t = Grammar.n_symbol let compare = compare end) - let log = ref M.empty - let log_symbol s = - let c = try M.find s !log with _ -> 0 in - log:= M.add s (c+1) !log - ;; - let () = at_exit (fun () -> M.iter (fun i j -> - if j > 0 then - Printf.eprintf "%i->%i\n%!" - (Grammar.symbol i) j) !log ) - ;; - let blit a1 o1 a2 o2 l = if l != 0 then - for i = 0 to l - 1 do - a2.(o2 + i) <- a1.(o1 + i); - done - +let dispatch_param0 conf id2 y0 y1 = + match conf with + | Grammar2.C0 | Grammar2.C2 -> Grammar2.Node0 id2 + | Grammar2.C1 | Grammar2.C5 -> Grammar2.Node1(id2,y0) + | Grammar2.C3 | Grammar2.C6 -> y0 + | Grammar2.C4 -> Grammar2.Node2(id2, y0, y1) + +let dispatch_param1 conf id2 y0 y1 = + match conf with + | Grammar2.C2 -> y0 + | Grammar2.C3 -> Grammar2.Node0 id2 + | Grammar2.C5 -> y1 + | Grammar2.C6 -> Grammar2.Node1(id2, y1) + | _ -> Grammar2.dummy_param + + module K_down = struct + type t = Grammar2.n_symbol * StateSet.t + let hash (x,y) = HASHINT2(Node.to_int x, Uid.to_int y.StateSet.Node.id) + let equal (x1,y1) (x2,y2) = x1 == x2 && y1 == y2 + end + + module K_up = struct + type t = Grammar2.n_symbol * StateSet.t * StateSet.t * StateSet.t + let hash (a,b,c,d) = + HASHINT4 (Node.to_int a, + Uid.to_int b.StateSet.Node.id, + Uid.to_int c.StateSet.Node.id, + Uid.to_int d.StateSet.Node.id) + let equal (a1, b1, c1, d1) (a2, b2, c2, d2) = + a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 + end + + module DCache = + struct + include Hashtbl.Make(K_down) + let dummy = StateSet.singleton State.dummy + let notfound l = l.(0) == dummy && l.(1) == dummy + let find h k = + try + find h k + with + Not_found -> + let a = [| dummy; dummy |] in + add h k a; + a + end + module UCache = Hashtbl.Make(K_up) + type result = { + in0 : StateSet.t; + in1 : StateSet.t; + out0 : StateSet.t * U.t; + out1 : StateSet.t * U.t; + main : StateSet.t * U.t + } + let mk_empty e = + { in0 = StateSet.empty; + in1 = StateSet.empty; + out0 = e; + out1 = e; + main = e + } + let mk_nil s v = + { + mk_empty (s,v) with + out0 = StateSet.empty,v; + out1 = StateSet.empty,v; + } let grammar_run auto g () = - - let dummy_leaf = Grammar2.Leaf (Node.nil) in + let dummy_leaf = Grammar2.dummy_param in + let dummy_set = StateSet.singleton State.dummy in let res_len = (StateSet.max_elt auto.states) + 1 in let empty_slot = Array.create res_len U.NS.empty in - let nil_res = auto.bottom_states, empty_slot in - let empty_res = StateSet.empty, empty_slot in + let nil_res = mk_nil auto.bottom_states empty_slot in + let empty_res = mk_empty (StateSet.empty, empty_slot) in let cache3 = L3JIT.create () in let dummy2 = (StateSet.empty, StateSet.empty, Translist.nil) in let cache2 = Cache.Lvl2.create 512 dummy2 in let rule_counter = ref 0 in - let start_counter = ref 0 in - let () = at_exit (fun () -> Printf.eprintf "start_couter=%i, rule_counter=%i\n%!" - !start_counter !rule_counter) in + let preorder_counter = ref 0 in + let dcache = DCache.create 1023 in + let ucache = UCache.create 1023 in + let term_array = [| StateSet.empty; StateSet.empty |] in let get_trans tag states = let c = Cache.Lvl2.find cache2 tag (Uid.to_int states.StateSet.Node.id) in if c == dummy2 then - let c = - StateSet.fold (fun q tr_acc -> - List.fold_left - (fun ((lstates, rstates, tacc) as acc) (ts, trs) -> - if TagSet.mem (Tag.translate tag) ts then - let _, _, _, phi = Transition.node trs in - let (_,_,l),(_,_,r) = Formula.st phi in - (StateSet.union l lstates, - StateSet.union r rstates, - Translist.cons trs tacc) - else acc) - tr_acc (Hashtbl.find auto.trans q) - ) states (StateSet.empty, StateSet.empty, Translist.nil) - in + let c = get_trans g auto tag states in begin Cache.Lvl2.add cache2 tag (Uid.to_int states.StateSet.Node.id) c; c end else c in + let lambda = ref 0 in let rec start_loop idx states = - incr (start_counter); TRACE("grammar", 2, __ "Node %i\n%!" (Node.to_int idx)); + if states == dummy_set then nil_res else if idx < Node.null then nil_res - else if StateSet.is_empty states then empty_res else begin let symbol = Grammar2.start_tag g idx in + let fc = Grammar2.start_first_child g idx in + let ns = Grammar2.start_next_sibling g fc in if Grammar2.is_terminal g symbol then - let symbol = Grammar2.terminal symbol in - if symbol == Grammar2.nil_symbol then nil_res else - let tag = Grammar2.tag symbol in - let lst, rst, trans = get_trans tag states in - let fs = Grammar2.start_first_child g idx in - let s1, slot1 = start_loop fs lst in - let s2, slot2 = start_loop (Grammar2.start_next_sibling g fs) rst in - let opcode = L3JIT.find cache3 trans s1 s2 in - if opcode == L3JIT.dummy then - (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic ()) - else opcode empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic()) + let t = Grammar2.terminal symbol in + terminal_loop t states (Grammar2.Leaf (~-1,0,term_array, fc)) (Grammar2.Leaf (~-1,1,term_array, ns)) else let nt = Grammar2.non_terminal symbol in - let rhs = Grammar2.get_rule g nt in - let nparam = Grammar2.get_rank rhs in - match nparam with - | 0 -> rule_loop nt states 0 dummy_leaf dummy_leaf - | 1 -> rule_loop nt states 1 (Grammar2.Leaf(Grammar2.start_first_child g idx)) dummy_leaf - | 2 -> - let fc = Grammar2.start_first_child g idx in - let ns = Grammar2.start_next_sibling g fc in - rule_loop nt states 2 (Grammar2.Leaf fc) (Grammar2.Leaf ns) - | _ -> assert false + incr lambda; + let lmbd = !lambda in + let y0 = (Grammar2.Leaf (lmbd,0, term_array, fc)) + and y1 = (Grammar2.Leaf (lmbd,1, term_array, ns)) in + rule_loop nt states y0 y1 end - and rule_loop (t : Grammar2.n_symbol) states rank y0 y1 = - incr rule_counter; - if !rule_counter land (65535) == 0 then begin Gc.minor() end; - let rhs = Grammar2.get_rule g t in - let id1 = Grammar2.get_id1 rhs in - let id2 = Grammar2.get_id2 rhs in - let conf = Grammar2.get_conf rhs in - if Grammar2.is_non_terminal g id1 then - let id1 = Grammar2.non_terminal id1 in - match conf with - | Grammar2.C0 -> rule_loop id1 states 1 (Grammar2.Node0 id2) dummy_leaf - | Grammar2.C1 -> rule_loop id1 states 1 (Grammar2.Node1(id2,y0)) dummy_leaf - | Grammar2.C2 -> rule_loop id1 states 2 (Grammar2.Node0 id2) y0 - | Grammar2.C3 -> rule_loop id1 states 2 y0 (Grammar2.Node0 id2) - | Grammar2.C4 -> rule_loop id1 states 1 (Grammar2.Node2(id2, y0, y1)) dummy_leaf - | Grammar2.C5 -> rule_loop id1 states 2 (Grammar2.Node1(id2, y0)) y1 - | Grammar2.C6 -> rule_loop id1 states 2 y0 (Grammar2.Node1(id2, y1)) - else - let id1 = Grammar2.terminal id1 in - match conf with - | Grammar2.C0 | Grammar2.C1 -> assert false - | Grammar2.C2 -> terminal_loop id1 states (Grammar2.Node0 id2) y0 - | Grammar2.C3 -> terminal_loop id1 states y0 (Grammar2.Node0 id2) - | Grammar2.C4 -> assert false - | Grammar2.C5 -> terminal_loop id1 states (Grammar2.Node1(id2, y0)) y1 - | Grammar2.C6 -> terminal_loop id1 states y0 (Grammar2.Node1(id2, y1)) + and rule_loop (t : Grammar2.n_symbol) states y0 y1 = + if t = Node.nil || states == dummy_set then nil_res else + let () = incr rule_counter in + if !rule_counter land 65535 == 0 then begin Gc.minor() end; + let k = (t, states) in + let pstates = DCache.find dcache k in + let notfound = DCache.notfound pstates in + let rhs = Grammar2.get_rule g t in + let id1 = Grammar2.get_id1 rhs in + let id2 = Grammar2.get_id2 rhs in + let conf = Grammar2.get_conf rhs in + if notfound then + let ny0 = dispatch_param0 conf id2 y0 y1 in + let ny1 = dispatch_param1 conf id2 y0 y1 in + let res = dispatch_loop id1 states ny0 ny1 in + pstates.(0) <- res.in0; + pstates.(1) <- res.in1; + res (* + UCache.add ucache (t, states, fst res.out0, fst res.out1) + res.main; + let h = Hashtbl.create 7 in + for i = 0 to res_len - 1 do + Hashtbl.add h (0, i) (snd res.out0).(i); + Hashtbl.add h (1, i) (snd res.out1).(i); + done; + { res with + main = ((fst res.main), (U.close h (snd res.main))); + } *) + + else + let res0 = partial_loop y0 pstates.(0) in + let res1 = partial_loop y1 pstates.(1) in + let k2 = (t, states, fst res0.main, fst res1.main) in + let s, r = + try + UCache.find ucache k2 + with + Not_found -> + let ores0 = { res0 with main = fst res0.main, U.var 0 (snd res0.main) } + and ores1 = { res1 with main = fst res1.main, U.var 1 (snd res1.main) } + in + let res = dispatch_loop id1 states (Grammar2.Cache (0,ores0)) (Grammar2.Cache (1, ores1)) in + UCache.add ucache k2 res.main; + res.main + in + let h = Hashtbl.create 7 in + for i = 0 to res_len - 1 do + Hashtbl.add h (0, i) (snd res0.main).(i); + Hashtbl.add h (1, i) (snd res1.main).(i); + done; + { in0 = pstates.(0); + in1 = pstates.(1); + out0 = res0.main; + out1 = res1.main; + main = s, U.close h r; + } + + and dispatch_loop id1 states ny0 ny1 = + if Grammar2.is_non_terminal g id1 then + rule_loop (Grammar2.non_terminal id1) states ny0 ny1 + else + terminal_loop (Grammar2.terminal id1) states ny0 ny1 and terminal_loop (symbol : Grammar2.t_symbol) states y0 y1 = - if symbol == Grammar2.nil_symbol then nil_res else begin - (* todo factor in from start_loop *) + + if symbol == Grammar2.nil_symbol || symbol = Node.nil || states == dummy_set then nil_res else begin let tag = Grammar2.tag symbol in let lst, rst, trans = get_trans tag states in - let s1, slot1 = partial_loop y0 lst in - let s2, slot2 = partial_loop y1 rst in + let res0 = partial_loop y0 lst in + let res1 = partial_loop y1 rst in + let s1, slot1 = res0.main + and s2, slot2 = res1.main in let opcode = L3JIT.find cache3 trans s1 s2 in - if opcode == L3JIT.dummy then - (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic ()) - else - opcode empty_slot slot1 slot2 (Obj.magic()) (Obj.magic()) + let node = Node.of_int !preorder_counter in + incr preorder_counter; + let res = + if opcode == L3JIT.dummy then + (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) node + else + opcode empty_slot slot1 slot2 (Obj.magic()) (node) + in + { in0 = lst; + in1 = rst; + out0 = res0.main; + out1 = res1.main; + main = res } end and partial_loop l states = - match l with - | Grammar2.Leaf id -> start_loop id states - | Grammar2.Node0 id -> - if (Grammar2.terminal id) == Grammar2.nil_symbol then nil_res - else - rule_loop (Grammar2.non_terminal id) states 0 dummy_leaf dummy_leaf - | Grammar2.Node1 (id, y0) -> - rule_loop (Grammar2.non_terminal id) states 1 y0 dummy_leaf - | Grammar2.Node2 (id, y0, y1) -> - if Grammar2.is_terminal g id then + if l == dummy_leaf then nil_res else + match l with + | Grammar2.Cache (_, r) -> r + | Grammar2.Leaf (_,_, _, id) -> start_loop id states + | Grammar2.Node0 id -> + if (Grammar2.terminal id) == Grammar2.nil_symbol then nil_res + else + rule_loop (Grammar2.non_terminal id) states dummy_leaf dummy_leaf + + | Grammar2.Node1 (id, y0) -> + rule_loop (Grammar2.non_terminal id) states y0 dummy_leaf + | Grammar2.Node2 (id, y0, y1) -> + if Grammar2.is_terminal g id then terminal_loop (Grammar2.terminal id) states y0 y1 - else - rule_loop (Grammar2.non_terminal id) states 1 y0 y1 + else + rule_loop (Grammar2.non_terminal id) states y0 y1 in - let _, slot = start_loop (Node.null) auto.init in + let (_, slot) = (start_loop (Node.null) auto.init).main in slot.(StateSet.min_elt auto.topdown_marking_states) ;; -- 2.17.1