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