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