src/runtime.ml

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