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 grammar_run : Ata.t -> Grammar2.t -> unit -> result_set
  12   val naive_top_down_run : Ata.t -> Tree.t -> Tree.node -> result_set
  13   val twopass_top_down_run : Ata.t -> Tree.t -> Tree.node -> result_set
  14 end
  15
  16 module Make (U : ResJIT.S) : S with type result_set = U.NS.t =
  17   struct
  18
  19     type result_set = U.NS.t;;
  20
  21     let eval_form auto s1 s2 f =
  22       let rec loop f =
  23         match Formula.expr f with
  24           | Formula.False | Formula.True | Formula.Pred _ -> f, []
  25           | Formula.Atom(`Left, b, q) ->
  26               Formula.of_bool (b == (StateSet.mem q s1)),
  27               if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.LEFT q] else []
  28           | Formula.Atom (`Right, b, q) ->
  29               Formula.of_bool(b == (StateSet.mem q s2)),
  30               if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.RIGHT q] else []
  31           | Formula.Atom (`Epsilon, _, _) -> assert false
  32
  33           | Formula.Or(f1, f2) ->
  34               let b1, i1 = loop f1 in
  35               let b2, i2 = loop f2 in
  36               Formula.or_pred b1 b2, i1 @ i2
  37           | Formula.And(f1, f2) ->
  38               let b1, i1 = loop f1 in
  39               let b2, i2 = loop f2 in
  40               Formula.and_pred b1 b2, i1 @ i2
  41       in
  42       loop f
  43
  44
  45     let eval_trans auto s1 s2 trans =
  46       LOG(__ "top-down-run" 3 "Evaluating transition list:@\n%a" Translist.print trans);
  47       Translist.fold
  48         (fun t ((a_st, a_op, a_todo) as acc)->
  49            let q, _, m, f = Transition.node t in
  50            let form, ops = eval_form auto s1 s2 f in
  51            match Formula.expr form with
  52              | Formula.True ->
  53                StateSet.add q a_st,
  54                (q, (if m then (ResJIT.SELF() :: ops) else ops)):: a_op,
  55                a_todo
  56              | Formula.False -> acc
  57              | Formula.Pred p -> a_st, a_op,
  58                (p.Tree.Predicate.node, q, [(q,(if m then (ResJIT.SELF() :: ops) else ops))]) :: a_todo
  59              | _ -> assert false
  60         ) trans (StateSet.empty, [], [])
  61
  62
  63
  64     module L3JIT =
  65       struct
  66
  67         type opcode = (t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t)
  68
  69         type t = opcode Cache.Lvl3.t
  70
  71         let dummy _ _ _ _ _ = failwith "Uninitialized L3JIT"
  72
  73
  74         let show_stats a =
  75           let count = ref 0 in
  76           Cache.Lvl3.iteri (fun _ _ _ _ b -> if not b then incr count) a;
  77           Logger.print err_formatter "@?L3JIT: %i used entries@\n@?" !count
  78         let create () =
  79           let v = Cache.Lvl3.create 1024 dummy in
  80           if !Options.verbose then at_exit (fun () -> show_stats v);
  81           v
  82
  83         let find t tlist s1 s2 =
  84           Cache.Lvl3.find t
  85             (Uid.to_int s2.StateSet.Node.id)
  86             (Uid.to_int s1.StateSet.Node.id)
  87             (Uid.to_int tlist.Translist.Node.id)
  88
  89         let add t tlist s1 s2 v =
  90           Cache.Lvl3.add 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             v
  95
  96         let compile auto trl s1 s2 =
  97           let orig_s1, orig_s2 =
  98             Translist.fold (fun t (a1, a2) ->
  99                           let _, _, _, f = Transition.node t in
 100                           let fs1, fs2 = Formula.st f in
 101                             (StateSet.union a1 fs1, StateSet.union a2 fs2)
 102                        ) trl (StateSet.empty, StateSet.empty)
 103           in
 104           let ns1 = StateSet.inter s1 orig_s1
 105           and ns2 = StateSet.inter s2 orig_s2 in
 106           let res, ops, todo = eval_trans auto ns1 ns2 trl in
 107           let code, not_marking = ResJIT.compile ops in
 108           let todo_code, todo_notmarking =
 109             List.fold_left (fun (l, b) (p, q, o) -> let c, b' = ResJIT.compile o in
 110                                          (p, q, c)::l, b && b')
 111               ([], not_marking) todo
 112           in
 113           let opcode = res, code, todo_notmarking, todo_code in
 114           opcode
 115
 116         let choose_slot empty sl1 sl2 =
 117           if sl1 != empty then sl1
 118           else if sl2 != empty then sl2
 119           else Array.copy empty
 120
 121         let gen_code auto tlist s1 s2 =
 122           let res, code, not_marking, todo_code = compile auto tlist s1 s2 in
 123           let f =
 124             if todo_code == [] then begin
 125               if not_marking then begin fun empty_slot sl1 sl2 _ node ->
 126                 if sl1 == empty_slot && sl2 == empty_slot then res, empty_slot
 127                 else
 128                   let sl = choose_slot empty_slot sl1 sl2 in
 129                   U.exec sl sl1 sl2 node code;
 130                   res, sl
 131               end else (* marking *) begin fun empty_slot sl1 sl2 _ node ->
 132                 let sl = choose_slot empty_slot sl1 sl2 in
 133                 U.exec sl sl1 sl2 node code;
 134                 res, sl
 135               end
 136             end else (* todo_code *) begin fun empty_slot sl1 sl2 tree node ->
 137               let sl = choose_slot empty_slot sl1 sl2 in
 138               U.exec sl sl1 sl2 node code;
 139               List.fold_left
 140                 (fun ares (p, q, code) ->
 141                   if !p tree node then begin
 142                     if code != ResJIT.Nil then U.exec sl sl1 sl2 node code;
 143                     StateSet.add q ares
 144                   end
 145                   else ares) res todo_code, sl
 146             end
 147           in
 148           f
 149
 150         let cache_apply cache auto tlist s1 s2 =
 151           let f = gen_code auto tlist s1 s2 in
 152           LOG(__ "grammar" 2 "Inserting: %i, %a, %a\n%!"
 153             (Uid.to_int tlist.Translist.Node.id) StateSet.print s1 StateSet.print s2);
 154           add cache tlist s1 s2 f; f
 155       end
 156
 157 DEFINE LOOP (t, states, ctx) = (
 158   let _t = t in
 159   LOG(__ "top-down-run" 3
 160         "Entering node %i with loop (tag %s, context %i) with states %a"
 161         (Node.to_int _t)
 162         (Tag.to_string (Tree.tag tree _t))
 163         (Node.to_int (ctx))
 164         (StateSet.print) (states));
 165   if _t == Tree.nil then nil_res
 166   else
 167     let tag = Tree.tag tree _t in
 168       l2jit_dispatch
 169         _t tag (states) (ctx) (L2JIT.find cache2 tag (states))
 170 )
 171
 172 DEFINE LOOP_TAG (t, states, tag, ctx) = (
 173   let _t = (t) in (* to avoid duplicating expression t *)
 174   LOG(__ "top-down-run" 3
 175         "Entering node %i with loop_tag (tag %s, context %i) with states %a"
 176           (Node.to_int _t)
 177           (Tag.to_string (tag))
 178           (Node.to_int (ctx))
 179           (StateSet.print) (states));
 180   if _t == Tree.nil then nil_res
 181   else
 182     l2jit_dispatch
 183       _t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states)))
 184
 185
 186     let top_down_run auto tree root states ctx =
 187       let res_len = StateSet.max_elt auto.states + 1 in
 188       let empty_slot = Array.create res_len U.NS.empty in
 189       let nil_res = auto.bottom_states, empty_slot in
 190
 191       let mark_subtree s subtree =
 192         if subtree != U.NS.empty then
 193           let r = Array.copy empty_slot in
 194           r.(auto.last) <- subtree;
 195           s, r
 196         else
 197           s, empty_slot
 198       in
 199       let cache3 = L3JIT.create () in
 200       let l3jit_dispatch trl s1 s2 t sl1 sl2 =
 201         let f = L3JIT.find cache3 trl s1 s2 in
 202         if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
 203         else f empty_slot sl1 sl2 tree t
 204       in
 205       let cache2 = L2JIT.create () in
 206       let rec loop t states ctx =
 207         if t == Tree.nil then nil_res
 208         else
 209           let tag = Tree.tag tree t in
 210           l2jit_dispatch
 211             t tag (states) (ctx) (L2JIT.find cache2 tag (states))
 212       and loop_tag t states ctx tag =
 213         if t == Tree.nil then nil_res
 214         else
 215           l2jit_dispatch
 216             t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states))
 217
 218       and l2jit_dispatch t tag states ctx opcode =
 219         match opcode with
 220           | L2JIT.RETURN _ -> nil_res
 221           | L2JIT.LEFT (tr_list, instr) ->
 222               let res1, slot1 =
 223                 l2jit_dispatch_instr t (Tree.closing tree t) instr
 224               in
 225               l3jit_dispatch tr_list res1 auto.bottom_states t slot1 empty_slot
 226
 227           | L2JIT.RIGHT (tr_list, instr) ->
 228             let res2, slot2 =
 229               l2jit_dispatch_instr t ctx instr
 230             in
 231             l3jit_dispatch tr_list auto.bottom_states res2 t empty_slot slot2
 232
 233           | L2JIT.BOTH (tr_list, instr1, instr2) ->
 234               let res1, slot1 =
 235                 l2jit_dispatch_instr t (Tree.closing tree t) instr1
 236               in
 237               let res2, slot2 =
 238                 l2jit_dispatch_instr t ctx instr2
 239               in
 240                 l3jit_dispatch tr_list res1 res2 t slot1 slot2
 241           | L2JIT.CACHE _ ->
 242             LOG(__ "top-down-run" 3
 243                   "Top-down cache miss for configuration %s %a"
 244                   (Tag.to_string tag) StateSet.print states);
 245             l2jit_dispatch t tag states ctx
 246               (L2JIT.compile cache2 auto tree tag states)
 247
 248     and l2jit_dispatch_instr t ctx instr =
 249         LOG(__ "top-down-run" 3 "Dispatching instr: %a on node %i (context=%i)"
 250               L2JIT.print_jump instr (Node.to_int t) (Node.to_int ctx));
 251         match instr with
 252         | L2JIT.NOP _ -> nil_res
 253         | L2JIT.FIRST_CHILD s -> loop (Tree.first_child tree t) s ctx
 254         | L2JIT.NEXT_SIBLING s -> loop (Tree.next_sibling tree t) s ctx
 255
 256         | L2JIT.FIRST_ELEMENT s -> loop (Tree.first_element tree t) s ctx
 257         | L2JIT.NEXT_ELEMENT s -> loop (Tree.next_element tree t) s ctx
 258
 259         | L2JIT.TAGGED_DESCENDANT (s, tag) ->
 260           loop_tag (Tree.tagged_descendant tree t tag) s ctx tag
 261
 262         | L2JIT.TAGGED_FOLLOWING (s, tag) ->
 263           loop_tag (Tree.tagged_following_before tree t tag ctx) s ctx  tag
 264
 265         | L2JIT.SELECT_DESCENDANT (s, _, us) ->
 266           loop (Tree.select_descendant tree t us) s ctx
 267
 268         | L2JIT.SELECT_FOLLOWING (s, pt, us) ->
 269           loop (Tree.select_following_before tree t us ctx) s ctx
 270
 271         | L2JIT.TAGGED_CHILD (s, tag) ->
 272           loop_tag (Tree.tagged_child tree t tag) s ctx tag
 273
 274         | L2JIT.TAGGED_SIBLING (s, tag) ->
 275           loop_tag (Tree.tagged_sibling tree t tag) s ctx tag
 276
 277         | L2JIT.SELECT_CHILD (s, _, us) ->
 278           loop (Tree.select_child tree t us) s ctx
 279
 280         | L2JIT.SELECT_SIBLING (s, _, us) ->
 281           loop (Tree.select_sibling tree t us) s ctx
 282
 283         | L2JIT.TAGGED_SUBTREE(s, tag) ->
 284           mark_subtree s (U.NS.subtree_tags tree t tag)
 285
 286         | L2JIT.ELEMENT_SUBTREE(s) ->
 287           mark_subtree s (U.NS.subtree_elements tree t)
 288       in
 289       let r = loop root states ctx in
 290       r
 291
 292     let full_top_down_run auto states tree root =
 293       top_down_run auto tree root states (Tree.closing tree root)
 294
 295     let top_down_run auto tree root =
 296       Ata.init ();
 297       let res, slot = full_top_down_run auto auto.init tree root in
 298       slot.(StateSet.min_elt auto.topdown_marking_states)
 299
 300
 301     (*** Bottom-up evaluation function **)
 302
 303     let eval_trans auto tree parent res1 res2 = assert false
 304
 305     let rec uniq = function
 306       | ([] | [ _ ]) as l -> l
 307       | e1 :: ((e2 :: ll) as l) -> if e1 == e2 then uniq l
 308         else e1 :: e2 :: (uniq ll);;
 309
 310 DEFINE BOTTOM_UP_NEXT(node, rest, stop) =
 311       (let ___fs = Tree.first_child tree node in
 312        let ___res1 =
 313          if ___fs == Tree.nil then nil_res
 314          else full_top_down_run auto states tree ___fs
 315        in
 316        move_up node ___res1 true rest stop)
 317
 318
 319     let bottom_up_run auto tree (query, pat) =
 320       let array = time ~msg:"Timing text query" (Tree.full_text_query query tree) pat in
 321       let leaves = Array.to_list array in
 322       let states = auto.states in
 323       let res_len = (StateSet.max_elt states) + 1 in
 324       let empty_slot = Array.create res_len U.NS.empty in
 325       let nil_res = auto.bottom_states, empty_slot in
 326       let cache = Cache.Lvl3.create 0 L3JIT.dummy in
 327       let rec move_up node res is_left rest stop =
 328         if node == stop then res, rest
 329         else
 330           (*let prev_sibling = Tree.prev_sibling tree node in *)
 331           let is_left' = Tree.is_first_child tree node (*prev_sibling == Tree.nil*) in
 332           (*TODO: unsound in case of following-sibling moves
 333             should replace the else by previous_sibling and walk up the sequence of
 334             right child moves *)
 335           let parent = if is_left' then Tree.parent tree node else
 336               let p = Tree.first_child tree (Tree.parent tree node) in
 337               if p < stop then stop else p
 338           in
 339           let (s1, sl1), (s2, sl2), rest' =
 340             if is_left then match rest with
 341                 [] -> res, nil_res, rest
 342               | next :: rest' ->
 343                 if Tree.is_right_descendant tree node next
 344                 then
 345                   let res2, rest' = (*bottom_up_next*) BOTTOM_UP_NEXT(next, rest', node) in
 346                   res, res2, rest'
 347                 else res, nil_res, rest
 348             else
 349               nil_res, res, rest
 350           in
 351           let tag = Tree.tag tree node in
 352           let id1 = Uid.to_int s1.StateSet.Node.id in
 353           let id2 = Uid.to_int s2.StateSet.Node.id in
 354           let code =
 355             let code = Cache.Lvl3.find cache id2 id1 tag in
 356             if code == L3JIT.dummy  then
 357               let trl =
 358                 StateSet.fold
 359                   (fun q acc ->
 360                     List.fold_left (fun acc' (labels, tr) ->
 361                       if TagSet.mem tag labels
 362                       then Translist.cons tr acc' else acc')
 363                       acc
 364                       (Hashtbl.find auto.trans q)
 365                   )
 366                   states
 367                   Translist.nil
 368               in
 369               let code = L3JIT.gen_code auto trl s1 s2 in
 370               Cache.Lvl3.add cache id2 id1 tag code; code
 371             else code
 372           in
 373           let res' = code empty_slot sl1 sl2 tree node in
 374           move_up parent res' is_left' rest' stop
 375       in
 376       let loop_leaves l =
 377         match l with
 378           [] -> nil_res
 379         | node :: ll ->
 380           let res, lll = BOTTOM_UP_NEXT( (*bottom_up_next*) node, ll, Tree.nil) in
 381           if lll <> [] then
 382             Logger.print err_formatter "WARNING: Leftover nodes: %i\n" (List.length lll);
 383           res
 384       in
 385     let _, slot = loop_leaves leaves in
 386     slot.(StateSet.min_elt auto.topdown_marking_states)
 387
 388
 389 let get_trans g auto tag states =
 390   StateSet.fold (fun q tr_acc ->
 391     List.fold_left
 392       (fun ((lstates, rstates, tacc) as acc) (ts, trs) ->
 393         if TagSet.mem (Tag.translate tag) ts then
 394           if not (TagSet.mem Tag.attribute ts) && Grammar2.is_attribute g tag
 395           then acc
 396               else
 397             let _, _, _, phi = Transition.node trs in
 398                 let l, r = Formula.st phi in
 399                 (StateSet.union l lstates,
 400                  StateSet.union r rstates,
 401                  Translist.cons trs tacc)
 402         else acc)
 403       tr_acc (Hashtbl.find auto.trans q)
 404   ) states (StateSet.empty, StateSet.empty, Translist.nil)
 405
 406 (*  Grammar run *)
 407 let dispatch_param0 conf id2 y0 y1 =
 408   match conf with
 409   | Grammar2.C0 | Grammar2.C2 -> Grammar2.Node0 id2
 410   | Grammar2.C1 | Grammar2.C5 -> Grammar2.Node1(id2,y0)
 411   | Grammar2.C3 | Grammar2.C6 -> y0
 412   | Grammar2.C4 -> Grammar2.Node2(id2, y0, y1)
 413
 414 let dispatch_param1 conf id2 y0 y1 =
 415   match conf with
 416   | Grammar2.C2 -> y0
 417   | Grammar2.C3 -> Grammar2.Node0 id2
 418   | Grammar2.C5 -> y1
 419   | Grammar2.C6 -> Grammar2.Node1(id2, y1)
 420   | _ -> Grammar2.dummy_param
 421
 422     module K_down = struct
 423       type t = Grammar2.n_symbol * StateSet.t
 424       let hash (x,y) = HASHINT2(Node.to_int x, Uid.to_int y.StateSet.Node.id)
 425       let equal (x1,y1) (x2,y2) = x1 == x2 && y1 == y2
 426     end
 427
 428     module K_up = struct
 429       type t = Grammar2.n_symbol * StateSet.t * StateSet.t * StateSet.t
 430       let hash (a,b,c,d) =
 431         HASHINT4 (Node.to_int a,
 432                   Uid.to_int b.StateSet.Node.id,
 433                   Uid.to_int c.StateSet.Node.id,
 434                   Uid.to_int d.StateSet.Node.id)
 435       let equal (a1, b1, c1, d1) (a2, b2, c2, d2) =
 436         a1 == a2 && b1  == b2 && c1 == c2 && d1 == d2
 437     end
 438
 439     module DCache =
 440       struct
 441         include Hashtbl.Make(K_down)
 442         let dummy = StateSet.singleton State.dummy
 443         let notfound l = l.(0) == dummy && l.(1) == dummy
 444         let find h k =
 445           try
 446             find h k
 447           with
 448             Not_found ->
 449               let a = [| dummy; dummy |] in
 450               add h k a;
 451               a
 452       end
 453     module UCache = Hashtbl.Make(K_up)
 454     type result = {
 455       in0 : StateSet.t;
 456       in1 : StateSet.t;
 457       out0 : StateSet.t * U.t;
 458       out1 : StateSet.t * U.t;
 459       main : StateSet.t * U.t
 460     }
 461     let mk_empty e =
 462       { in0 = StateSet.empty;
 463         in1 = StateSet.empty;
 464         out0 = e;
 465         out1 = e;
 466         main = e
 467       }
 468     let mk_nil s v  =
 469       {
 470         mk_empty (s,v) with
 471           out0 = StateSet.empty,v;
 472           out1 = StateSet.empty,v;
 473       }
 474
 475     let grammar_run auto g () =
 476       let dummy_leaf = Grammar2.dummy_param in
 477       let dummy_set = StateSet.singleton State.dummy in
 478       let res_len = (StateSet.max_elt auto.states) + 1 in
 479       let empty_slot = Array.create res_len U.NS.empty in
 480       let nil_res = mk_nil auto.bottom_states empty_slot in
 481       let cache3 = L3JIT.create () in
 482       let dummy2 = (StateSet.empty, StateSet.empty, Translist.nil) in
 483       let cache2 = Cache.Lvl2.create 512 dummy2 in
 484       let rule_counter = ref 0 in
 485       let preorder_counter = ref 0 in
 486       let term_array = [| StateSet.empty; StateSet.empty |] in
 487       let get_trans tag states =
 488         let c = Cache.Lvl2.find cache2 tag (Uid.to_int states.StateSet.Node.id) in
 489         if c == dummy2 then
 490           let c = get_trans g auto tag states in
 491           begin
 492             Cache.Lvl2.add cache2 tag (Uid.to_int states.StateSet.Node.id) c;
 493             c
 494           end
 495         else c
 496       in
 497       let lambda = ref 0 in
 498       let rec start_loop idx states =
 499         LOG(__ "grammar" 2 "Node %i\n%!" (Node.to_int idx));
 500         if states == dummy_set then nil_res else
 501         if idx < Node.null then nil_res
 502         else begin
 503           let symbol = Grammar2.start_tag g idx in
 504           let fc = Grammar2.start_first_child g idx in
 505           let ns = Grammar2.start_next_sibling g fc in
 506           if Grammar2.is_terminal g symbol then
 507             let t = Grammar2.terminal symbol in
 508               terminal_loop t states (Grammar2.Leaf (~-1,0,term_array, fc)) (Grammar2.Leaf (~-1,1,term_array, ns))
 509           else
 510             let nt = Grammar2.non_terminal symbol in
 511             incr lambda;
 512             let lmbd = !lambda in
 513             let y0 = (Grammar2.Leaf (lmbd,0, term_array, fc))
 514             and y1 = (Grammar2.Leaf (lmbd,1, term_array, ns)) in
 515             rule_loop nt states y0 y1
 516         end
 517       and rule_loop (t : Grammar2.n_symbol) states y0 y1 =
 518         if t = Node.nil || states == dummy_set then nil_res else
 519           let () = incr rule_counter in
 520           if !rule_counter land 65535 == 0 then begin Gc.minor() end;
 521 (*          let k = (t, states) in*)
 522 (*          let pstates = DCache.find dcache k in
 523           let notfound = DCache.notfound pstates in *)
 524           let rhs = Grammar2.get_rule g t in
 525           let id1 = Grammar2.get_id1 rhs in
 526           let id2 = Grammar2.get_id2 rhs in
 527           let conf = Grammar2.get_conf rhs in
 528 (*          if notfound then*)
 529             let ny0 = dispatch_param0 conf id2 y0 y1 in
 530             let ny1 = dispatch_param1 conf id2 y0 y1 in
 531             let res = dispatch_loop id1 states ny0 ny1 in
 532 (*            pstates.(0) <- res.in0;
 533             pstates.(1) <- res.in1; *)
 534             res (*
 535             UCache.add ucache (t, states, fst res.out0, fst res.out1)
 536               res.main;
 537             let h = Hashtbl.create 7 in
 538             for i = 0 to res_len - 1 do
 539               Hashtbl.add h (0, i) (snd res.out0).(i);
 540               Hashtbl.add h (1, i) (snd res.out1).(i);
 541             done;
 542             { res with
 543               main = ((fst res.main), (U.close h (snd res.main)));
 544             } *)
 545 (*
 546             else
 547               let res0 = partial_loop y0 pstates.(0) in
 548               let res1 = partial_loop y1 pstates.(1) in
 549               let k2 = (t, states, fst res0.main, fst res1.main) in
 550               let s, r =
 551                 try
 552                   UCache.find ucache k2
 553                 with
 554                 Not_found ->
 555                   let ores0 = { res0 with main = fst res0.main, U.var 0 (snd res0.main) }
 556                   and ores1 = { res1 with main = fst res1.main, U.var 1 (snd res1.main) }
 557                   in
 558                   let res = dispatch_loop id1 states (Grammar2.Cache (0,ores0)) (Grammar2.Cache (1, ores1)) in
 559                   UCache.add ucache k2 res.main;
 560                   res.main
 561               in
 562               let h = Hashtbl.create 7 in
 563               for i = 0 to res_len - 1 do
 564                 Hashtbl.add h (0, i) (snd res0.main).(i);
 565                 Hashtbl.add h (1, i) (snd res1.main).(i);
 566               done;
 567               { in0 = pstates.(0);
 568                 in1 = pstates.(1);
 569                 out0 = res0.main;
 570                 out1 = res1.main;
 571                 main = s, U.close h r;
 572               }
 573 *)
 574       and dispatch_loop id1 states ny0 ny1 =
 575           if Grammar2.is_non_terminal g id1 then
 576             rule_loop (Grammar2.non_terminal id1) states ny0 ny1
 577           else
 578             terminal_loop (Grammar2.terminal id1) states ny0 ny1
 579
 580       and terminal_loop (symbol : Grammar2.t_symbol) states y0 y1 =
 581
 582         if symbol == Grammar2.nil_symbol || symbol = Node.nil || states == dummy_set then nil_res else begin
 583           let tag = Grammar2.tag symbol in
 584           let lst, rst, trans = get_trans tag states in
 585           let res0 = partial_loop y0 lst in
 586           let res1 = partial_loop y1 rst in
 587           let s1, slot1 = res0.main
 588           and s2, slot2 = res1.main in
 589           let opcode = L3JIT.find cache3 trans s1 s2 in
 590           let node = Node.of_int !preorder_counter in
 591           incr preorder_counter;
 592           let res =
 593             if opcode == L3JIT.dummy then
 594               (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) node
 595             else
 596               opcode empty_slot slot1 slot2 (Obj.magic())  (node)
 597           in
 598           { in0 = lst;
 599             in1 = rst;
 600             out0 = res0.main;
 601             out1 = res1.main;
 602             main = res }
 603         end
 604
 605       and partial_loop l states =
 606         if l == dummy_leaf then nil_res else
 607           match l with
 608           | Grammar2.Cache (_, r) -> r
 609           | Grammar2.Leaf (_,_, _, id) -> start_loop id states
 610           | Grammar2.Node0 id ->
 611             if (Grammar2.terminal id) == Grammar2.nil_symbol then nil_res
 612             else
 613               rule_loop (Grammar2.non_terminal id) states dummy_leaf dummy_leaf
 614
 615           | Grammar2.Node1 (id, y0) ->
 616             rule_loop (Grammar2.non_terminal id) states y0 dummy_leaf
 617           | Grammar2.Node2 (id, y0, y1) ->
 618             if Grammar2.is_terminal g id then
 619             terminal_loop (Grammar2.terminal id) states y0 y1
 620             else
 621               rule_loop (Grammar2.non_terminal id) states y0 y1
 622       in
 623
 624       let (_, slot) = (start_loop (Node.null) auto.init).main in
 625       slot.(StateSet.min_elt auto.topdown_marking_states)
 626     ;;
 627
 628
 629     (* Slow reference top-down implementation *)
 630     let naive_top_down auto tree root states ctx =
 631       let res_len = StateSet.max_elt auto.states + 1 in
 632       let empty_slot = Array.create res_len U.NS.empty in
 633       let nil_res = auto.bottom_states, empty_slot in
 634       let cache3 = L3JIT.create () in
 635       let l3jit_dispatch trl s1 s2 t sl1 sl2 =
 636         let f = L3JIT.find cache3 trl s1 s2 in
 637         if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
 638         else f empty_slot sl1 sl2 tree t
 639       in
 640       let dummy = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 641       let cache2 = Cache.Lvl2.create 512 dummy in
 642       let rec loop t states ctx =
 643         if states == StateSet.empty then nil_res
 644         else if t == Tree.nil then (*StateSet.inter states auto.bottom_states, empty_slot *) nil_res
 645         else
 646           let tag = Tree.tag tree t in
 647
 648           let trans, lstates, rstates =
 649             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 650             if c == dummy then
 651               let c = Ata.get_trans auto states tag in
 652               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 653               c
 654             else c
 655           in
 656           let s1, res1 = loop (Tree.first_child tree t) lstates ctx
 657           and s2, res2 = loop (Tree.next_sibling tree t) rstates ctx in
 658           l3jit_dispatch trans s1 s2 t res1 res2
 659       in
 660       loop root states ctx
 661
 662
 663
 664
 665     let naive_top_down_run auto tree root =
 666       let res, slot = naive_top_down auto tree root auto.init (Tree.closing tree root) in
 667       slot.(StateSet.min_elt auto.topdown_marking_states)
 668
 669
 670
 671     let eval_form auto s1 s2 f =
 672       let rec loop f =
 673         match Formula.expr f with
 674           | Formula.False | Formula.True | Formula.Pred _ -> f
 675           | Formula.Atom(`Left, b, q) ->
 676               Formula.of_bool (b == (StateSet.mem q s1))
 677           | Formula.Atom (`Right, b, q) ->
 678               Formula.of_bool(b == (StateSet.mem q s2))
 679           | Formula.Atom (`Epsilon, _, _) -> assert false
 680
 681           | Formula.Or(f1, f2) ->
 682               let b1 = loop f1 in
 683               let b2 = loop f2 in
 684               Formula.or_pred b1 b2
 685           | Formula.And(f1, f2) ->
 686               let b1 = loop f1 in
 687               let b2 = loop f2 in
 688               Formula.and_pred b1 b2
 689       in
 690       loop f
 691
 692     let eval_trans auto s1 s2 trans =
 693       Translist.fold
 694         (fun t ((a_st, mark) as acc)->
 695            let q, _, m, f = Transition.node t in
 696            let form = eval_form auto s1 s2 f in
 697            match Formula.expr form with
 698              | Formula.True -> StateSet.add q a_st, mark || m
 699              | Formula.False -> acc
 700              | _ -> assert false
 701         ) trans (StateSet.empty, false)
 702
 703
 704     let set a i v =
 705       LOG(__ "twopass" 2 "Setting node %i to state %a\n%!"
 706         i StateSet.print v);
 707       a.(i) <- v
 708
 709     let twopass_top_down states_array auto tree root states ctx =
 710       let dummy3 = StateSet.singleton State.dummy in
 711       let cache3 = Cache.Lvl3.create 512  dummy3 in
 712       let dummy2 = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 713       let cache2 = Cache.Lvl2.create 512 dummy2 in
 714       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 715       let rec loop t states ctx =
 716         if t == Tree.nil then auto.bottom_states
 717         else if states == StateSet.empty then
 718           let () = set states_array (Node.to_int t) auto.bottom_states in
 719           auto.bottom_states
 720         else
 721           let tag = Tree.tag tree t in
 722           LOG(__ "twopass" 2 "Traversing node %i (tag %s) in states %a\n%!" (Node.to_int t) (Tag.to_string tag)
 723           StateSet.print states
 724           );
 725           let trans, lstates, rstates =
 726             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 727             if c == dummy2 then
 728               let c = Ata.get_trans ~attributes:attributes auto states tag in
 729               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 730               c
 731             else c
 732           in
 733           LOG(__ "twopass" 2 "\nTransitions are:\n%!");
 734           LOG(__ "twopass" 2"\nTransitions are:\n%a\n%!"
 735             Translist.print trans
 736           );
 737           let s1 = loop (Tree.first_child tree t) lstates ctx
 738           and s2 = loop (Tree.next_sibling tree t) rstates ctx in
 739           let st =
 740             let c = Cache.Lvl3.find cache3
 741               (Uid.to_int s1.StateSet.Node.id)
 742               (Uid.to_int s2.StateSet.Node.id)
 743               (Uid.to_int trans.Translist.Node.id)
 744             in
 745             if c == dummy3 then
 746               let c, _ = eval_trans auto s1 s2 trans in
 747               Cache.Lvl3.add cache3
 748                 (Uid.to_int s1.StateSet.Node.id)
 749                 (Uid.to_int s2.StateSet.Node.id)
 750                 (Uid.to_int trans.Translist.Node.id) c;c
 751             else c
 752           in
 753           set states_array (Node.to_int t) st;
 754           st
 755       in
 756       loop root states ctx, (dummy2, cache2)
 757
 758
 759     type action = Nop | Mark | Dummy
 760
 761     let twopass_top_down_scan states_array (dummy2, cache2) auto tree root states ctx =
 762       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 763       let cache3 = Cache.Lvl3.create 512  Dummy in
 764       let rec loop t states acc =
 765         if states == StateSet.empty || t = Tree.nil then acc
 766         else
 767           let tag = Tree.tag tree t in
 768           let trans, _, _ =
 769           let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 770             if c == dummy2 then
 771               let c = Ata.get_trans  ~attributes:attributes auto states tag in
 772               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 773               c
 774             else c
 775           in
 776           let fs = Tree.first_child tree t in
 777           let ns = Tree.next_sibling tree t in
 778           let s1 = if fs != Tree.nil then states_array.(Node.to_int fs) else auto.bottom_states
 779           and s2 = if ns != Tree.nil then states_array.(Node.to_int ns) else auto.bottom_states
 780           in
 781           let mark =
 782             let c = Cache.Lvl3.find cache3
 783               (Uid.to_int s1.StateSet.Node.id)
 784               (Uid.to_int s2.StateSet.Node.id)
 785               (Uid.to_int trans.Translist.Node.id)
 786             in
 787             if c == Dummy then
 788               let _, c = eval_trans auto s1 s2 trans in
 789               let c = if c then Mark else Nop in
 790                Cache.Lvl3.add cache3
 791                  (Uid.to_int s1.StateSet.Node.id)
 792                  (Uid.to_int s2.StateSet.Node.id)
 793                  (Uid.to_int trans.Translist.Node.id) c;c
 794             else c
 795           in
 796           LOG(__ "twopass" 2 "Evaluating node %i (tag %s).\n%!States=%a\n%!"
 797             (Node.to_int t)
 798             (Tag.to_string tag)
 799             StateSet.print states
 800           );
 801           LOG(__ "twopass" 2 "Translist=%a\nLeft=%a\nRight=%a\nMark=%s\n\n%!"
 802             Translist.print trans
 803             StateSet.print s1
 804             StateSet.print s2
 805             (match mark with
 806               Dummy -> "Dummy"
 807             | Mark -> "Mark"
 808             | Nop -> "Nop"));
 809           if mark == Mark then
 810             loop ns s2 (loop fs s1 (U.NS.snoc acc t))
 811           else
 812             loop ns s2 (loop fs s1 acc)
 813       in
 814       loop root states U.NS.empty
 815
 816     let twopass_top_down_run auto tree root =
 817       let len = Node.to_int (Tree.closing tree root) + 1 in
 818       LOG(__ "twopass" 2 "Creating array of size: %i\n%!" len);
 819       let states_array = Array.make len StateSet.empty in
 820       let _, cache =
 821         twopass_top_down states_array auto tree root auto.init Tree.nil
 822       in
 823       twopass_top_down_scan states_array cache auto tree root auto.init Tree.nil
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834   end