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 orig_s1 orig_s2 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 empty_res = mk_empty (StateSet.empty, empty_slot) in
 488       let cache3 = L3JIT.create () in
 489       let dummy2 = (StateSet.empty, StateSet.empty, Translist.nil) in
 490       let cache2 = Cache.Lvl2.create 512 dummy2 in
 491       let rule_counter = ref 0 in
 492       let preorder_counter = ref 0 in
 493       let dcache = DCache.create 1023 in
 494       let ucache = UCache.create 1023 in
 495       let term_array = [| StateSet.empty; StateSet.empty |] in
 496       let get_trans tag states =
 497         let c = Cache.Lvl2.find cache2 tag (Uid.to_int states.StateSet.Node.id) in
 498         if c == dummy2 then
 499           let c = get_trans g auto tag states in
 500           begin
 501             Cache.Lvl2.add cache2 tag (Uid.to_int states.StateSet.Node.id) c;
 502             c
 503           end
 504         else c
 505       in
 506       let lambda = ref 0 in
 507       let rec start_loop idx states =
 508         LOG(__ "grammar" 2 "Node %i\n%!" (Node.to_int idx));
 509         if states == dummy_set then nil_res else
 510         if idx < Node.null then nil_res
 511         else begin
 512           let symbol = Grammar2.start_tag g idx in
 513           let fc = Grammar2.start_first_child g idx in
 514           let ns = Grammar2.start_next_sibling g fc in
 515           if Grammar2.is_terminal g symbol then
 516             let t = Grammar2.terminal symbol in
 517               terminal_loop t states (Grammar2.Leaf (~-1,0,term_array, fc)) (Grammar2.Leaf (~-1,1,term_array, ns))
 518           else
 519             let nt = Grammar2.non_terminal symbol in
 520             incr lambda;
 521             let lmbd = !lambda in
 522             let y0 = (Grammar2.Leaf (lmbd,0, term_array, fc))
 523             and y1 = (Grammar2.Leaf (lmbd,1, term_array, ns)) in
 524             rule_loop nt states y0 y1
 525         end
 526       and rule_loop (t : Grammar2.n_symbol) states y0 y1 =
 527         if t = Node.nil || states == dummy_set then nil_res else
 528           let () = incr rule_counter in
 529           if !rule_counter land 65535 == 0 then begin Gc.minor() end;
 530 (*        let k = (t, states) in*)
 531 (*        let pstates = DCache.find dcache k in
 532           let notfound = DCache.notfound pstates in *)
 533           let rhs = Grammar2.get_rule g t in
 534           let id1 = Grammar2.get_id1 rhs in
 535           let id2 = Grammar2.get_id2 rhs in
 536           let conf = Grammar2.get_conf rhs in
 537 (*        if notfound then*)
 538             let ny0 = dispatch_param0 conf id2 y0 y1 in
 539             let ny1 = dispatch_param1 conf id2 y0 y1 in
 540             let res = dispatch_loop id1 states ny0 ny1 in
 541 (*          pstates.(0) <- res.in0;
 542             pstates.(1) <- res.in1; *)
 543             res (*
 544             UCache.add ucache (t, states, fst res.out0, fst res.out1)
 545               res.main;
 546             let h = Hashtbl.create 7 in
 547             for i = 0 to res_len - 1 do
 548               Hashtbl.add h (0, i) (snd res.out0).(i);
 549               Hashtbl.add h (1, i) (snd res.out1).(i);
 550             done;
 551             { res with
 552               main = ((fst res.main), (U.close h (snd res.main)));
 553             } *)
 554 (*
 555             else
 556               let res0 = partial_loop y0 pstates.(0) in
 557               let res1 = partial_loop y1 pstates.(1) in
 558               let k2 = (t, states, fst res0.main, fst res1.main) in
 559               let s, r =
 560                 try
 561                   UCache.find ucache k2
 562                 with
 563                 Not_found ->
 564                   let ores0 = { res0 with main = fst res0.main, U.var 0 (snd res0.main) }
 565                   and ores1 = { res1 with main = fst res1.main, U.var 1 (snd res1.main) }
 566                   in
 567                   let res = dispatch_loop id1 states (Grammar2.Cache (0,ores0)) (Grammar2.Cache (1, ores1)) in
 568                   UCache.add ucache k2 res.main;
 569                   res.main
 570               in
 571               let h = Hashtbl.create 7 in
 572               for i = 0 to res_len - 1 do
 573                 Hashtbl.add h (0, i) (snd res0.main).(i);
 574                 Hashtbl.add h (1, i) (snd res1.main).(i);
 575               done;
 576               { in0 = pstates.(0);
 577                 in1 = pstates.(1);
 578                 out0 = res0.main;
 579                 out1 = res1.main;
 580                 main = s, U.close h r;
 581               }
 582 *)
 583       and dispatch_loop id1 states ny0 ny1 =
 584           if Grammar2.is_non_terminal g id1 then
 585             rule_loop (Grammar2.non_terminal id1) states ny0 ny1
 586           else
 587             terminal_loop (Grammar2.terminal id1) states ny0 ny1
 588
 589       and terminal_loop (symbol : Grammar2.t_symbol) states y0 y1 =
 590
 591         if symbol == Grammar2.nil_symbol || symbol = Node.nil || states == dummy_set then nil_res else begin
 592           let tag = Grammar2.tag symbol in
 593           let lst, rst, trans = get_trans tag states in
 594           let res0 = partial_loop y0 lst in
 595           let res1 = partial_loop y1 rst in
 596           let s1, slot1 = res0.main
 597           and s2, slot2 = res1.main in
 598           let opcode = L3JIT.find cache3 trans s1 s2 in
 599           let node = Node.of_int !preorder_counter in
 600           incr preorder_counter;
 601           let res =
 602             if opcode == L3JIT.dummy then
 603               (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) node
 604             else
 605               opcode empty_slot slot1 slot2 (Obj.magic())  (node)
 606           in
 607           { in0 = lst;
 608             in1 = rst;
 609             out0 = res0.main;
 610             out1 = res1.main;
 611             main = res }
 612         end
 613
 614       and partial_loop l states =
 615         if l == dummy_leaf then nil_res else
 616           match l with
 617           | Grammar2.Cache (_, r) -> r
 618           | Grammar2.Leaf (_,_, _, id) -> start_loop id states
 619           | Grammar2.Node0 id ->
 620             if (Grammar2.terminal id) == Grammar2.nil_symbol then nil_res
 621             else
 622               rule_loop (Grammar2.non_terminal id) states dummy_leaf dummy_leaf
 623
 624           | Grammar2.Node1 (id, y0) ->
 625             rule_loop (Grammar2.non_terminal id) states y0 dummy_leaf
 626           | Grammar2.Node2 (id, y0, y1) ->
 627             if Grammar2.is_terminal g id then
 628             terminal_loop (Grammar2.terminal id) states y0 y1
 629             else
 630               rule_loop (Grammar2.non_terminal id) states y0 y1
 631       in
 632
 633       let (_, slot) = (start_loop (Node.null) auto.init).main in
 634       slot.(StateSet.min_elt auto.topdown_marking_states)
 635     ;;
 636
 637
 638     (* Slow reference top-down implementation *)
 639     let naive_top_down auto tree root states ctx =
 640       let res_len = StateSet.max_elt auto.states + 1 in
 641       let empty_slot = Array.create res_len U.NS.empty in
 642       let nil_res = auto.bottom_states, empty_slot in
 643       let cache3 = L3JIT.create () in
 644       let l3jit_dispatch trl s1 s2 t sl1 sl2 =
 645         let f = L3JIT.find cache3 trl s1 s2 in
 646         if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
 647         else f empty_slot sl1 sl2 tree t
 648       in
 649       let dummy = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 650       let cache2 = Cache.Lvl2.create 512 dummy in
 651       let rec loop t states ctx =
 652         if states == StateSet.empty then nil_res
 653         else if t == Tree.nil then (*StateSet.inter states auto.bottom_states, empty_slot *) nil_res
 654         else
 655           let tag = Tree.tag tree t in
 656
 657           let trans, lstates, rstates =
 658             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 659             if c == dummy then
 660               let c = Ata.get_trans auto states tag in
 661               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 662               c
 663             else c
 664           in
 665           let s1, res1 = loop (Tree.first_child tree t) lstates ctx
 666           and s2, res2 = loop (Tree.next_sibling tree t) rstates ctx in
 667           l3jit_dispatch trans s1 s2 t res1 res2
 668       in
 669       loop root states ctx
 670
 671
 672
 673
 674     let naive_top_down_run auto tree root =
 675       let res, slot = naive_top_down auto tree root auto.init (Tree.closing tree root) in
 676       slot.(StateSet.min_elt auto.topdown_marking_states)
 677
 678
 679
 680     let eval_form auto s1 s2 f =
 681       let rec loop f =
 682         match Formula.expr f with
 683           | Formula.False | Formula.True | Formula.Pred _ -> f
 684           | Formula.Atom(`Left, b, q) ->
 685               Formula.of_bool (b == (StateSet.mem q s1))
 686           | Formula.Atom (`Right, b, q) ->
 687               Formula.of_bool(b == (StateSet.mem q s2))
 688           | Formula.Atom (`Epsilon, _, _) -> assert false
 689
 690           | Formula.Or(f1, f2) ->
 691               let b1 = loop f1 in
 692               let b2 = loop f2 in
 693               Formula.or_pred b1 b2
 694           | Formula.And(f1, f2) ->
 695               let b1 = loop f1 in
 696               let b2 = loop f2 in
 697               Formula.and_pred b1 b2
 698       in
 699       loop f
 700
 701     let eval_trans auto s1 s2 trans =
 702       Translist.fold
 703         (fun t ((a_st, mark) as acc)->
 704            let q, _, m, f = Transition.node t in
 705            let form = eval_form auto s1 s2 f in
 706            match Formula.expr form with
 707              | Formula.True -> StateSet.add q a_st, mark || m
 708              | Formula.False -> acc
 709              | _ -> assert false
 710         ) trans (StateSet.empty, false)
 711
 712
 713     let set a i v =
 714       LOG(__ "twopass" 2 "Setting node %i to state %a\n%!"
 715         i StateSet.print v);
 716       a.(i) <- v
 717
 718     let twopass_top_down states_array auto tree root states ctx =
 719       let dummy3 = StateSet.singleton State.dummy in
 720       let cache3 = Cache.Lvl3.create 512  dummy3 in
 721       let dummy2 = Translist.nil, StateSet.singleton State.dummy, StateSet.singleton State.dummy in
 722       let cache2 = Cache.Lvl2.create 512 dummy2 in
 723       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 724       let rec loop t states ctx =
 725         if t == Tree.nil then auto.bottom_states
 726         else if states == StateSet.empty then
 727           let () = set states_array (Node.to_int t) auto.bottom_states in
 728           auto.bottom_states
 729         else
 730           let tag = Tree.tag tree t in
 731           LOG(__ "twopass" 2 "Traversing node %i (tag %s) in states %a\n%!" (Node.to_int t) (Tag.to_string tag)
 732           StateSet.print states
 733           );
 734           let trans, lstates, rstates =
 735             let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 736             if c == dummy2 then
 737               let c = Ata.get_trans ~attributes:attributes auto states tag in
 738               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 739               c
 740             else c
 741           in
 742           LOG(__ "twopass" 2 "\nTransitions are:\n%!");
 743           LOG(__ "twopass" 2"\nTransitions are:\n%a\n%!"
 744             Translist.print trans
 745           );
 746           let s1 = loop (Tree.first_child tree t) lstates ctx
 747           and s2 = loop (Tree.next_sibling tree t) rstates ctx in
 748           let st =
 749             let c = Cache.Lvl3.find cache3
 750               (Uid.to_int s1.StateSet.Node.id)
 751               (Uid.to_int s2.StateSet.Node.id)
 752               (Uid.to_int trans.Translist.Node.id)
 753             in
 754             if c == dummy3 then
 755               let c, _ = eval_trans auto s1 s2 trans in
 756               Cache.Lvl3.add cache3
 757                 (Uid.to_int s1.StateSet.Node.id)
 758                 (Uid.to_int s2.StateSet.Node.id)
 759                 (Uid.to_int trans.Translist.Node.id) c;c
 760             else c
 761           in
 762           set states_array (Node.to_int t) st;
 763           st
 764       in
 765       loop root states ctx, (dummy2, cache2)
 766
 767
 768     type action = Nop | Mark | Dummy
 769
 770     let twopass_top_down_scan states_array (dummy2, cache2) auto tree root states ctx =
 771       let attributes = TagSet.inj_positive (Tree.attribute_tags tree) in
 772       let cache3 = Cache.Lvl3.create 512  Dummy in
 773       let rec loop t states acc =
 774         if states == StateSet.empty || t = Tree.nil then acc
 775         else
 776           let tag = Tree.tag tree t in
 777           let trans, _, _ =
 778           let c = Cache.Lvl2.find cache2 (Uid.to_int states.StateSet.Node.id) tag in
 779             if c == dummy2 then
 780               let c = Ata.get_trans  ~attributes:attributes auto states tag in
 781               Cache.Lvl2.add cache2 (Uid.to_int states.StateSet.Node.id) tag c;
 782               c
 783             else c
 784           in
 785           let fs = Tree.first_child tree t in
 786           let ns = Tree.next_sibling tree t in
 787           let s1 = if fs != Tree.nil then states_array.(Node.to_int fs) else auto.bottom_states
 788           and s2 = if ns != Tree.nil then states_array.(Node.to_int ns) else auto.bottom_states
 789           in
 790           let mark =
 791             let c = Cache.Lvl3.find cache3
 792               (Uid.to_int s1.StateSet.Node.id)
 793               (Uid.to_int s2.StateSet.Node.id)
 794               (Uid.to_int trans.Translist.Node.id)
 795             in
 796             if c == Dummy then
 797               let _, c = eval_trans auto s1 s2 trans in
 798               let c = if c then Mark else Nop in
 799                Cache.Lvl3.add cache3
 800                  (Uid.to_int s1.StateSet.Node.id)
 801                  (Uid.to_int s2.StateSet.Node.id)
 802                  (Uid.to_int trans.Translist.Node.id) c;c
 803             else c
 804           in
 805           LOG(__ "twopass" 2 "Evaluating node %i (tag %s).\n%!States=%a\n%!"
 806             (Node.to_int t)
 807             (Tag.to_string tag)
 808             StateSet.print states
 809           );
 810           LOG(__ "twopass" 2 "Translist=%a\nLeft=%a\nRight=%a\nMark=%s\n\n%!"
 811             Translist.print trans
 812             StateSet.print s1
 813             StateSet.print s2
 814             (match mark with
 815               Dummy -> "Dummy"
 816             | Mark -> "Mark"
 817             | Nop -> "Nop"));
 818           if mark == Mark then
 819             loop ns s2 (loop fs s1 (U.NS.snoc acc t))
 820           else
 821             loop ns s2 (loop fs s1 acc)
 822       in
 823       loop root states U.NS.empty
 824
 825     let twopass_top_down_run auto tree root =
 826       let len = Node.to_int (Tree.closing tree root) + 1 in
 827       LOG(__ "twopass" 2 "Creating array of size: %i\n%!" len);
 828       let states_array = Array.make len StateSet.empty in
 829       let _, cache =
 830         twopass_top_down states_array auto tree root auto.init Tree.nil
 831       in
 832       twopass_top_down_scan states_array cache auto tree root auto.init Tree.nil
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843   end
 844