src/runtime.ml

   1 INCLUDE "debug.ml"
   2 INCLUDE "log.ml"
   3 INCLUDE "utils.ml"
   4
   5 open Format
   6 open Ata
   7 module type S = sig
   8   type result_set
   9   val top_down_run : Ata.t -> Tree.t -> Tree.node -> result_set
  10   val bottom_up_run : Ata.t -> Tree.t -> Compile.text_query * string -> result_set
  11   val naive_top_down_run : Ata.t -> Tree.t -> Tree.node -> result_set
  12   val twopass_top_down_run : Ata.t -> Tree.t -> Tree.node -> result_set
  13 end
  14
  15 module Make (U : ResJIT.S) : S with type result_set = U.NS.t =
  16   struct
  17
  18     type result_set = U.NS.t;;
  19
  20     let eval_form auto s1 s2 f =
  21       let rec loop f =
  22         match Formula.expr f with
  23           | Formula.False | Formula.True | Formula.Pred _ -> f, []
  24           | Formula.Atom(`Left, b, q) ->
  25               Formula.of_bool (b == (StateSet.mem q s1)),
  26               if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.LEFT q] else []
  27           | Formula.Atom (`Right, b, q) ->
  28               Formula.of_bool(b == (StateSet.mem q s2)),
  29               if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.RIGHT q] else []
  30           | Formula.Atom (`Epsilon, _, _) -> assert false
  31
  32           | Formula.Or(f1, f2) ->
  33               let b1, i1 = loop f1 in
  34               let b2, i2 = loop f2 in
  35               Formula.or_pred b1 b2, i1 @ i2
  36           | Formula.And(f1, f2) ->
  37               let b1, i1 = loop f1 in
  38               let b2, i2 = loop f2 in
  39               Formula.and_pred b1 b2, i1 @ i2
  40       in
  41       loop f
  42
  43
  44     let eval_trans auto s1 s2 trans =
  45       LOG(__ "top-down-run" 3 "Evaluating transition list:@\n%a" Translist.print trans);
  46       Translist.fold
  47         (fun t ((a_st, a_op, a_todo) as acc)->
  48            let q, _, m, f = Transition.node t in
  49            let form, ops = eval_form auto s1 s2 f in
  50            match Formula.expr form with
  51              | Formula.True ->
  52                StateSet.add q a_st,
  53                (q, (if m then (ResJIT.SELF() :: ops) else ops)):: a_op,
  54                a_todo
  55              | Formula.False -> acc
  56              | Formula.Pred p -> a_st, a_op,
  57                (p.Tree.Predicate.node, q, [(q,(if m then (ResJIT.SELF() :: ops) else ops))]) :: a_todo
  58              | _ -> assert false
  59         ) trans (StateSet.empty, [], [])
  60
  61
  62
  63     module L3JIT =
  64       struct
  65
  66         type opcode = (t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t)
  67
  68         type t = opcode Cache.Lvl3.t
  69
  70         let dummy _ _ _ _ _ = failwith "Uninitialized L3JIT"
  71
  72
  73         let show_stats a =
  74           let count = ref 0 in
  75           Cache.Lvl3.iteri (fun _ _ _ _ b -> if not b then incr count) a;
  76           Logger.start_msg err_formatter "[Debug] L3JIT used: ";
  77           Logger.msg err_formatter "%i enttries" !count;
  78           Logger.end_msg err_formatter "\n\n"
  79
  80         let _has_exit = ref false
  81         let create () =
  82           let v = Cache.Lvl3.create 1024 dummy in
  83           if !Config.verbose && not !_has_exit then begin
  84             _has_exit := true;
  85             at_exit (fun () -> show_stats v);
  86           end;
  87           v
  88
  89         let find t tlist s1 s2 =
  90           Cache.Lvl3.find t
  91             (Uid.to_int s2.StateSet.Node.id)
  92             (Uid.to_int s1.StateSet.Node.id)
  93             (Uid.to_int tlist.Translist.Node.id)
  94
  95         let add t tlist s1 s2 v =
  96           Cache.Lvl3.add t
  97             (Uid.to_int s2.StateSet.Node.id)
  98             (Uid.to_int s1.StateSet.Node.id)
  99             (Uid.to_int tlist.Translist.Node.id)
 100             v
 101
 102         let compile auto trl s1 s2 =
 103           let orig_s1, orig_s2 =
 104             Translist.fold (fun t (a1, a2) ->
 105                           let _, _, _, f = Transition.node t in
 106                           let fs1, fs2 = Formula.st f in
 107                             (StateSet.union a1 fs1, StateSet.union a2 fs2)
 108                        ) trl (StateSet.empty, StateSet.empty)
 109           in
 110           let ns1 = StateSet.inter s1 orig_s1
 111           and ns2 = StateSet.inter s2 orig_s2 in
 112           let res, ops, todo = eval_trans auto ns1 ns2 trl in
 113           let code, not_marking = ResJIT.compile ops in
 114           let todo_code, todo_notmarking =
 115             List.fold_left (fun (l, b) (p, q, o) -> let c, b' = ResJIT.compile o in
 116                                          (p, q, c)::l, b && b')
 117               ([], not_marking) todo
 118           in
 119           let opcode = res, code, todo_notmarking, todo_code in
 120           opcode
 121
 122         let choose_slot empty sl1 sl2 =
 123           if sl1 != empty then sl1
 124           else if sl2 != empty then sl2
 125           else Array.copy empty
 126
 127         let gen_code auto tlist s1 s2 =
 128           let res, code, not_marking, todo_code = compile auto tlist s1 s2 in
 129           let f =
 130             if todo_code == [] then begin
 131               if not_marking then begin fun empty_slot sl1 sl2 _ node ->
 132                 if sl1 == empty_slot && sl2 == empty_slot then res, empty_slot
 133                 else
 134                   let sl = choose_slot empty_slot sl1 sl2 in
 135                   U.exec sl sl1 sl2 node code;
 136                   res, sl
 137               end else (* marking *) begin fun empty_slot sl1 sl2 _ node ->
 138                 let sl = choose_slot empty_slot sl1 sl2 in
 139                 U.exec sl sl1 sl2 node code;
 140                 res, sl
 141               end
 142             end else (* todo_code *) begin fun empty_slot sl1 sl2 tree node ->
 143               let sl = choose_slot empty_slot sl1 sl2 in
 144               LOG( __ "bottom-up" 3 "Has todo code\n");
 145               U.exec sl sl1 sl2 node code;
 146               List.fold_left
 147                 (fun ares (p, q, code) ->
 148                   if !p tree node then begin
 149                     if code != ResJIT.Nil then U.exec sl sl1 sl2 node code;
 150                     StateSet.add q ares
 151                   end
 152                   else ares) res todo_code, sl
 153             end
 154           in
 155           f
 156
 157         let cache_apply cache auto tlist s1 s2 =
 158           let f = gen_code auto tlist s1 s2 in
 159           LOG(__ "top-down-run" 2 "Inserting: %i, %a, %a\n%!"
 160             (Uid.to_int tlist.Translist.Node.id) StateSet.print s1 StateSet.print s2);
 161           if not !Config.no_cache then add cache tlist s1 s2 f;
 162           f
 163       end
 164
 165 DEFINE LOOP (t, states, ctx) = (
 166   let _t = t in
 167   LOG(__ "top-down-run" 3
 168         "Entering node %i with loop (tag %s, context %i) with states %a"
 169         (Node.to_int _t)
 170         (Tag.to_string (Tree.tag tree _t))
 171         (Node.to_int (ctx))
 172         (StateSet.print) (states));
 173   if _t == Tree.nil then nil_res
 174   else
 175     let tag = Tree.tag tree _t in
 176       l2jit_dispatch
 177         _t tag (states) (ctx) (L2JIT.find cache2 tag (states))
 178 )
 179
 180 DEFINE LOOP_TAG (t, states, tag, ctx) = (
 181   let _t = (t) in (* to avoid duplicating expression t *)
 182   LOG(__ "top-down-run" 3
 183         "Entering node %i with loop_tag (tag %s, context %i) with states %a"
 184           (Node.to_int _t)
 185           (Tag.to_string (tag))
 186           (Node.to_int (ctx))
 187           (StateSet.print) (states));
 188   if _t == Tree.nil then nil_res
 189   else
 190     l2jit_dispatch
 191       _t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states)))
 192
 193
 194     let top_down_run auto tree root states ctx =
 195       let res_len = StateSet.max_elt auto.states + 1 in
 196       let empty_slot = Array.create res_len U.NS.empty in
 197       let nil_res = auto.bottom_states, empty_slot in
 198
 199       let mark_subtree s subtree =
 200         if subtree != U.NS.empty then
 201           let r = Array.copy empty_slot in
 202           r.(auto.last) <- subtree;
 203           s, r
 204         else
 205           s, empty_slot
 206       in
 207       let cache3 = L3JIT.create () in
 208       let l3jit_dispatch trl s1 s2 t sl1 sl2 =
 209         let f = L3JIT.find cache3 trl s1 s2 in
 210         if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
 211         else f empty_slot sl1 sl2 tree t
 212       in
 213       let cache2 = L2JIT.create () in
 214       let rec loop t states ctx =
 215         if t == Tree.nil then nil_res
 216         else
 217           let tag = Tree.tag tree t in
 218           l2jit_dispatch
 219             t tag (states) (ctx) (L2JIT.find cache2 tag (states))
 220       and loop_tag t states ctx tag =
 221         if t == Tree.nil then nil_res
 222         else
 223           l2jit_dispatch
 224             t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states))
 225
 226       and l2jit_dispatch t tag states ctx opcode =
 227         match opcode with
 228           | L2JIT.RETURN () -> nil_res
 229           | L2JIT.LEFT (tr_list, instr) ->
 230               let res1, slot1 =
 231                 l2jit_dispatch_instr t (Tree.closing tree t) instr
 232               in
 233               l3jit_dispatch tr_list res1 auto.bottom_states t slot1 empty_slot
 234
 235           | L2JIT.RIGHT (tr_list, instr) ->
 236             let res2, slot2 =
 237               l2jit_dispatch_instr t ctx instr
 238             in
 239             l3jit_dispatch tr_list auto.bottom_states res2 t empty_slot slot2
 240
 241           | L2JIT.BOTH (tr_list, instr1, instr2) ->
 242               let res1, slot1 =
 243                 l2jit_dispatch_instr t (Tree.closing tree t) instr1
 244               in
 245               let res2, slot2 =
 246                 l2jit_dispatch_instr t ctx instr2
 247               in
 248                 l3jit_dispatch tr_list res1 res2 t slot1 slot2
 249           | L2JIT.CACHE () ->
 250             LOG(__ "top-down-run" 3
 251                   "Top-down cache miss for configuration %s %a"
 252                   (Tag.to_string tag) StateSet.print states);
 253             l2jit_dispatch t tag states ctx
 254               (L2JIT.compile cache2 auto tree tag states)
 255
 256     and l2jit_dispatch_instr t ctx instr =
 257         LOG(__ "top-down-run" 3 "Dispatching instr: %a on node %i (context=%i)"
 258               L2JIT.print_jump instr (Node.to_int t) (Node.to_int ctx));
 259         match instr with
 260         | L2JIT.NOP _ -> nil_res
 261         | L2JIT.FIRST_CHILD s -> loop (Tree.first_child tree t) s ctx
 262         | L2JIT.NEXT_SIBLING s -> loop (Tree.next_sibling tree t) s ctx
 263
 264         | L2JIT.FIRST_ELEMENT s -> loop (Tree.first_element tree t) s ctx
 265         | L2JIT.NEXT_ELEMENT s -> loop (Tree.next_element tree t) s ctx
 266
 267         | L2JIT.TAGGED_DESCENDANT (s, tag) ->
 268           loop_tag (Tree.tagged_descendant tree t tag) s ctx tag
 269
 270         | L2JIT.TAGGED_FOLLOWING (s, tag) ->
 271           loop_tag (Tree.tagged_following_before tree t tag ctx) s ctx  tag
 272
 273         | L2JIT.SELECT_DESCENDANT (s, _, us) ->
 274           loop (Tree.select_descendant tree t us) s ctx
 275
 276         | L2JIT.SELECT_FOLLOWING (s, pt, us) ->
 277           loop (Tree.select_following_before tree t us ctx) s ctx
 278
 279         | L2JIT.TAGGED_CHILD (s, tag) ->
 280           loop_tag (Tree.tagged_child tree t tag) s ctx tag
 281
 282         | L2JIT.TAGGED_SIBLING (s, tag) ->
 283           loop_tag (Tree.tagged_sibling tree t tag) s ctx tag
 284
 285         | L2JIT.SELECT_CHILD (s, _, us) ->
 286           loop (Tree.select_child tree t us) s ctx
 287
 288         | L2JIT.SELECT_SIBLING (s, _, us) ->
 289           loop (Tree.select_sibling tree t us) s ctx
 290
 291         | L2JIT.TAGGED_SUBTREE(s, tag) ->
 292           mark_subtree s (U.NS.subtree_tags tree t tag)
 293
 294         | L2JIT.ELEMENT_SUBTREE(s) ->
 295           mark_subtree s (U.NS.subtree_elements tree t)
 296       in
 297       let r = loop root states ctx in
 298       r
 299
 300     let full_top_down_run auto states tree root =
 301       top_down_run auto tree root states (Tree.closing tree root)
 302
 303     let top_down_run auto tree root =
 304       Ata.init ();
 305       L2JIT.init();
 306       let res, slot = full_top_down_run auto auto.init tree root in
 307       slot.(StateSet.min_elt auto.topdown_marking_states)
 308
 309
 310     (*** Bottom-up evaluation function **)
 311
 312     let eval_trans auto tree parent res1 res2 = assert false
 313
 314     let rec uniq = function
 315       | ([] | [ _ ]) as l -> l
 316       | e1 :: ((e2 :: ll) as l) -> if e1 == e2 then uniq l
 317         else e1 :: e2 :: (uniq ll);;
 318
 319 DEFINE BOTTOM_UP_NEXT(node, rest, stop) =
 320       (let ___fs = Tree.first_child tree node in
 321        let ___res1 =
 322          if ___fs == Tree.nil then nil_res
 323          else full_top_down_run auto states tree ___fs
 324        in
 325        move_up node ___res1 true rest stop)
 326
 327
 328     let bottom_up_run auto tree (query, pat) =
 329       let array = time ~msg:"Timing text query" (Tree.full_text_query query tree) pat in
 330       let leaves = Array.to_list array in
 331       let states = auto.states in
 332       let res_len = (StateSet.max_elt states) + 1 in
 333       let empty_slot = Array.create res_len U.NS.empty in
 334       let nil_res = auto.bottom_states, empty_slot in
 335       let cache = Cache.Lvl3.create 0 L3JIT.dummy in
 336       let rec move_up node res is_left rest stop =
 337         LOG(__ "bottom-up" 2 "move_up: node %i is_left %b stop %i\n"
 338               (Node.to_int node) is_left (Node.to_int stop));
 339         if node == stop then res, rest
 340         else
 341           (*let prev_sibling = Tree.prev_sibling tree node in *)
 342           let is_left' = Tree.is_first_child tree node (*prev_sibling == Tree.nil*) in
 343           (*TODO: unsound in case of following-sibling moves
 344             should replace the else by previous_sibling and walk up the sequence of
 345             right child moves *)
 346           let parent = if is_left' then Tree.parent tree node else
 347               let p = Tree.first_child tree (Tree.parent tree node) in
 348               if p < stop then stop else p
 349           in
 350           let (s1, sl1), (s2, sl2), rest' =
 351             if is_left then match rest with
 352                 [] -> res, nil_res, rest
 353               | next :: rest' ->
 354                 if Tree.is_right_descendant tree node next
 355                 then
 356                   let res2, rest' = (*bottom_up_next*) BOTTOM_UP_NEXT(next, rest', node) in
 357                   res, res2, rest'
 358                 else res, nil_res, rest
 359             else
 360               nil_res, res, rest
 361           in
 362           let tag = Tree.tag tree node in
 363           let id1 = Uid.to_int s1.StateSet.Node.id in
 364           let id2 = Uid.to_int s2.StateSet.Node.id in
 365           let code =
 366             let code = Cache.Lvl3.find cache id2 id1 tag in
 367             if code == L3JIT.dummy  then
 368               let trl =
 369                 StateSet.fold
 370                   (fun q acc ->
 371                     List.fold_left (fun acc' (labels, tr) ->
 372                       if TagSet.mem tag labels
 373                       then Translist.cons tr acc' else acc')
 374                       acc
 375                       (Hashtbl.find auto.trans q)
 376                   )
 377                   states
 378                   Translist.nil
 379               in
 380               LOG( __ "bottom-up" 3 "Transition list for %s, %a, %a is %a\n"
 381                      (Tag.to_string tag)
 382                      StateSet.print s1
 383                      StateSet.print s2
 384                      Translist.print trl
 385               );
 386               let code = L3JIT.gen_code auto trl s1 s2 in
 387               Cache.Lvl3.add cache id2 id1 tag code; code
 388             else code
 389           in
 390           let res' = code empty_slot sl1 sl2 tree node in
 391           move_up parent res' is_left' rest' stop
 392       in
 393       let loop_leaves l =
 394         match l with
 395           [] -> nil_res
 396         | node :: ll ->
 397           let res, lll = BOTTOM_UP_NEXT( (*bottom_up_next*) node, ll, Tree.nil) in
 398           if lll <> [] then
 399             Logger.print err_formatter "WARNING: Leftover nodes: %i\n" (List.length lll);
 400           res
 401       in
 402     let _, slot = loop_leaves leaves in
 403     slot.(StateSet.min_elt auto.topdown_marking_states)
 404
 405
 406
 407     (* Slow reference top-down implementation *)
 408     let naive_top_down auto tree root states ctx =
 409       let res_len = StateSet.max_elt auto.states + 1 in
 410       let empty_slot = Array.create res_len U.NS.empty in
 411       let nil_res = auto.bottom_states, empty_slot in
 412       let cache3 = L3JIT.create () in
 413       let l3jit_dispatch trl s1 s2 t sl1 sl2 =
 414         let f = L3JIT.find cache3 trl s1 s2 in
 415         if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
 416         else f empty_slot sl1 sl2 tree t
 417       in
 418       let dummy = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 419       let cache2 = Cache.Lvl2.create 512 dummy in
 420       let rec loop t states ctx =
 421         if states == StateSet.empty then nil_res
 422         else if t == Tree.nil then (*StateSet.inter states auto.bottom_states, empty_slot *) nil_res
 423         else
 424           let tag = Tree.tag tree t in
 425
 426           let trans, lstates, rstates =
 427             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 428             if c == dummy then
 429               let c = Ata.get_trans auto states tag in
 430               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 431               c
 432             else c
 433           in
 434           let s1, res1 = loop (Tree.first_child tree t) lstates ctx
 435           and s2, res2 = loop (Tree.next_sibling tree t) rstates ctx in
 436           l3jit_dispatch trans s1 s2 t res1 res2
 437       in
 438       loop root states ctx
 439
 440
 441
 442
 443     let naive_top_down_run auto tree root =
 444       let res, slot = naive_top_down auto tree root auto.init (Tree.closing tree root) in
 445       slot.(StateSet.min_elt auto.topdown_marking_states)
 446
 447
 448
 449     let eval_form auto s1 s2 f =
 450       let rec loop f =
 451         match Formula.expr f with
 452           | Formula.False | Formula.True | Formula.Pred _ -> f
 453           | Formula.Atom(`Left, b, q) ->
 454               Formula.of_bool (b == (StateSet.mem q s1))
 455           | Formula.Atom (`Right, b, q) ->
 456               Formula.of_bool(b == (StateSet.mem q s2))
 457           | Formula.Atom (`Epsilon, _, _) -> assert false
 458
 459           | Formula.Or(f1, f2) ->
 460               let b1 = loop f1 in
 461               let b2 = loop f2 in
 462               Formula.or_pred b1 b2
 463           | Formula.And(f1, f2) ->
 464               let b1 = loop f1 in
 465               let b2 = loop f2 in
 466               Formula.and_pred b1 b2
 467       in
 468       loop f
 469
 470     let eval_trans auto s1 s2 trans =
 471       Translist.fold
 472         (fun t ((a_st, mark) as acc)->
 473            let q, _, m, f = Transition.node t in
 474            let form = eval_form auto s1 s2 f in
 475            match Formula.expr form with
 476              | Formula.True -> StateSet.add q a_st, mark || m
 477              | Formula.False -> acc
 478              | _ -> assert false
 479         ) trans (StateSet.empty, false)
 480
 481
 482     let set a i v =
 483       LOG(__ "twopass" 2 "Setting node %i to state %a\n%!"
 484         i StateSet.print v);
 485       a.(i) <- v
 486
 487     let twopass_top_down states_array auto tree root states ctx =
 488       let dummy3 = StateSet.singleton State.dummy in
 489       let cache3 = Cache.Lvl3.create 512  dummy3 in
 490       let dummy2 = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 491       let cache2 = Cache.Lvl2.create 512 dummy2 in
 492       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 493       let rec loop t states ctx =
 494         if t == Tree.nil then auto.bottom_states
 495         else if states == StateSet.empty then
 496           let () = set states_array (Node.to_int t) auto.bottom_states in
 497           auto.bottom_states
 498         else
 499           let tag = Tree.tag tree t in
 500           LOG(__ "twopass" 2 "Traversing node %i (tag %s) in states %a\n%!" (Node.to_int t) (Tag.to_string tag)
 501           StateSet.print states
 502           );
 503           let trans, lstates, rstates =
 504             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 505             if c == dummy2 then
 506               let c = Ata.get_trans ~attributes:attributes auto states tag in
 507               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 508               c
 509             else c
 510           in
 511           LOG(__ "twopass" 2 "\nTransitions are:\n%!");
 512           LOG(__ "twopass" 2"\nTransitions are:\n%a\n%!"
 513             Translist.print trans
 514           );
 515           let s1 = loop (Tree.first_child tree t) lstates ctx
 516           and s2 = loop (Tree.next_sibling tree t) rstates ctx in
 517           let st =
 518             let c = Cache.Lvl3.find cache3
 519               (Uid.to_int s1.StateSet.Node.id)
 520               (Uid.to_int s2.StateSet.Node.id)
 521               (Uid.to_int trans.Translist.Node.id)
 522             in
 523             if c == dummy3 then
 524               let c, _ = eval_trans auto s1 s2 trans in
 525               Cache.Lvl3.add cache3
 526                 (Uid.to_int s1.StateSet.Node.id)
 527                 (Uid.to_int s2.StateSet.Node.id)
 528                 (Uid.to_int trans.Translist.Node.id) c;c
 529             else c
 530           in
 531           set states_array (Node.to_int t) st;
 532           st
 533       in
 534       loop root states ctx, (dummy2, cache2)
 535
 536
 537     type action = Nop | Mark | Dummy
 538
 539     let twopass_top_down_scan states_array (dummy2, cache2) auto tree root states ctx =
 540       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 541       let cache3 = Cache.Lvl3.create 512  Dummy in
 542       let rec loop t states acc =
 543         if states == StateSet.empty || t = Tree.nil then acc
 544         else
 545           let tag = Tree.tag tree t in
 546           let trans, _, _ =
 547           let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 548             if c == dummy2 then
 549               let c = Ata.get_trans  ~attributes:attributes auto states tag in
 550               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 551               c
 552             else c
 553           in
 554           let fs = Tree.first_child tree t in
 555           let ns = Tree.next_sibling tree t in
 556           let s1 = if fs != Tree.nil then states_array.(Node.to_int fs) else auto.bottom_states
 557           and s2 = if ns != Tree.nil then states_array.(Node.to_int ns) else auto.bottom_states
 558           in
 559           let mark =
 560             let c = Cache.Lvl3.find cache3
 561               (Uid.to_int s1.StateSet.Node.id)
 562               (Uid.to_int s2.StateSet.Node.id)
 563               (Uid.to_int trans.Translist.Node.id)
 564             in
 565             if c == Dummy then
 566               let _, c = eval_trans auto s1 s2 trans in
 567               let c = if c then Mark else Nop in
 568                Cache.Lvl3.add cache3
 569                  (Uid.to_int s1.StateSet.Node.id)
 570                  (Uid.to_int s2.StateSet.Node.id)
 571                  (Uid.to_int trans.Translist.Node.id) c;c
 572             else c
 573           in
 574           LOG(__ "twopass" 2 "Evaluating node %i (tag %s).\n%!States=%a\n%!"
 575             (Node.to_int t)
 576             (Tag.to_string tag)
 577             StateSet.print states
 578           );
 579           LOG(__ "twopass" 2 "Translist=%a\nLeft=%a\nRight=%a\nMark=%s\n\n%!"
 580             Translist.print trans
 581             StateSet.print s1
 582             StateSet.print s2
 583             (match mark with
 584               Dummy -> "Dummy"
 585             | Mark -> "Mark"
 586             | Nop -> "Nop"));
 587           if mark == Mark then
 588             loop ns s2 (loop fs s1 (U.NS.snoc acc t))
 589           else
 590             loop ns s2 (loop fs s1 acc)
 591       in
 592       loop root states U.NS.empty
 593
 594     let twopass_top_down_run auto tree root =
 595       let len = Node.to_int (Tree.closing tree root) + 1 in
 596       LOG(__ "twopass" 2 "Creating array of size: %i\n%!" len);
 597       let states_array = Array.make len StateSet.empty in
 598       let _, cache =
 599         twopass_top_down states_array auto tree root auto.init Tree.nil
 600       in
 601       twopass_top_down_scan states_array cache auto tree root auto.init Tree.nil
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612   end