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