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