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