- let cache = Cache.Lvl3.create 1024 L3JIT.dummy in
- let rec loop_leaves l acc =
- match l with
- [] -> acc
- | node :: ll ->
- let res, lll = bottom_up_next node ll Tree.nil in
- if (lll <> []) then
- begin
- eprintf "Leftover nodes: %i\n" (List.length lll);
- end;
- res
-
- and bottom_up_next node rest stop =
- let fs = Tree.first_child tree node in
- let res1 =
- if fs == Tree.nil then nil_res
- else full_top_down_run auto states tree fs
- in
- move_up node res1 true rest stop
-
- and move_up node res is_left rest stop =
- if node == stop then res, rest
- else
- let prev_sibling = Tree.prev_sibling tree node in
- let is_left' = prev_sibling == Tree.nil in
- let real_parent = Tree.parent tree node in
- let parent =
- if is_left' then real_parent else max (Tree.first_child tree real_parent) stop
- in
- (* let parent = if is_left' then Tree.parent tree node else prev_sibling in *)
- let (s1, sl1), (s2, sl2), rest' =
- if is_left then match rest with
- [] -> res, nil_res, rest
- | next :: rest' ->
- if Tree.is_right_descendant tree node next
- then
- let res2, rest' = bottom_up_next next rest' node in
- res, res2, rest'
- else res, nil_res, rest
- else
- nil_res, res, rest
- in
- let tag = Tree.tag tree node in
- let id1 = Uid.to_int s1.StateSet.Node.id in
- let id2 = Uid.to_int s2.StateSet.Node.id in
- let code =
- let code = Cache.Lvl3.find cache tag id1 id2 in
- if code == L3JIT.dummy then
- let trl =
- StateSet.fold
- (fun q acc ->
- List.fold_left (fun acc' (labels, tr) ->
- if labels == TagSet.any || TagSet.mem tag labels
- then Translist.cons tr acc' else acc')
- acc
- (Hashtbl.find auto.trans q)
- )
- states
- Translist.nil
- in
- let code = L3JIT.gen_code auto trl s1 s2 in
- Cache.Lvl3.add cache tag id1 id2 code; code
- else code
- in
- let res' = code empty_slot sl1 sl2 tree node in
- move_up parent res' is_left' rest' stop
- in
- 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 *)
-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.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 = mk_nil auto.bottom_states 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 preorder_counter = ref 0 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 = 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
+ let cache = Cache.Lvl3.create 0 L3JIT.dummy in
+ let rec move_up node res is_left rest stop =
+ LOG(__ "bottom-up" 2 "move_up: node %i is_left %b stop %i\n"
+ (Node.to_int node) is_left (Node.to_int stop));
+ if node == stop then res, rest
+ else
+ (*let prev_sibling = Tree.prev_sibling tree node in *)
+ let is_left' = Tree.is_first_child tree node (*prev_sibling == Tree.nil*) in
+ (*TODO: unsound in case of following-sibling moves
+ should replace the else by previous_sibling and walk up the sequence of
+ right child moves *)
+ let parent = if is_left' then Tree.parent tree node else
+ let p = Tree.first_child tree (Tree.parent tree node) in
+ if p < stop then stop else p
+ in
+ let (s1, sl1), (s2, sl2), rest' =
+ if is_left then match rest with
+ [] -> res, nil_res, rest
+ | next :: rest' ->
+ if Tree.is_right_descendant tree node next
+ then
+ let res2, rest' = (*bottom_up_next*) BOTTOM_UP_NEXT(next, rest', node) in
+ res, res2, rest'
+ else res, nil_res, rest
+ else
+ nil_res, res, rest
+ in
+ let tag = Tree.tag tree node in
+ let id1 = Uid.to_int s1.StateSet.Node.id in
+ let id2 = Uid.to_int s2.StateSet.Node.id in
+ let code =
+ let code = Cache.Lvl3.find cache id2 id1 tag in
+ if code == L3JIT.dummy then
+ let trl =
+ StateSet.fold
+ (fun q acc ->
+ List.fold_left (fun acc' (labels, tr) ->
+ if TagSet.mem tag labels
+ then Translist.cons tr acc' else acc')
+ acc
+ (Hashtbl.find auto.trans q)
+ )
+ states
+ Translist.nil
+ in
+ LOG( __ "bottom-up" 3 "Transition list for %s, %a, %a is %a\n"
+ (Tag.to_string tag)
+ StateSet.print s1
+ StateSet.print s2
+ Translist.print trl
+ );
+ let code = L3JIT.gen_code auto trl s1 s2 in
+ Cache.Lvl3.add cache id2 id1 tag code; code
+ else code
+ in
+ let res' = code empty_slot sl1 sl2 tree node in
+ move_up parent res' is_left' rest' stop