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
 225       let rec l2jit_dispatch t tag states ctx opcode =
 226         match opcode with
 227           | L2JIT.RETURN -> nil_res
 228           | L2JIT.CACHE ->
 229             LOG(__ "top-down-run" 3
 230                 "Top-down cache miss for configuration %s %a"
 231                   (Tag.to_string tag) StateSet.print states);
 232             let opcode = L2JIT.compile cache2 auto tree tag states in
 233             l2jit_dispatch t tag states ctx opcode
 234
 235           | L2JIT.LEFT (tr_list, instr) ->
 236               let res1, slot1 =
 237                 l2jit_dispatch_instr t (Tree.closing tree t) instr
 238               in
 239                 l3jit_dispatch tr_list res1 auto.bottom_states t slot1 empty_slot
 240
 241           | L2JIT.RIGHT (tr_list, instr) ->
 242             let res2, slot2 =
 243               l2jit_dispatch_instr t ctx instr
 244             in
 245             l3jit_dispatch tr_list auto.bottom_states res2 t empty_slot slot2
 246
 247           | L2JIT.BOTH (tr_list, instr1, instr2) ->
 248               let res1, slot1 =
 249                 l2jit_dispatch_instr t (Tree.closing tree t) instr1
 250               in
 251               let res2, slot2 =
 252                 l2jit_dispatch_instr t ctx instr2
 253               in
 254                 l3jit_dispatch tr_list res1 res2 t slot1 slot2
 255
 256     and l2jit_dispatch_instr t ctx instr =
 257         match instr with
 258         | L2JIT.NOP () -> nil_res
 259         | L2JIT.FIRST_CHILD s -> LOOP ((Tree.first_child tree t), s, ctx)
 260         | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_sibling tree t), s, ctx)
 261
 262         | L2JIT.FIRST_ELEMENT s -> LOOP ((Tree.first_element tree t), s, ctx)
 263         | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_element tree t), s, ctx)
 264
 265         | L2JIT.TAGGED_DESCENDANT (s, tag) ->
 266           LOOP_TAG ((Tree.tagged_descendant tree t tag), s, tag, ctx)
 267
 268         | L2JIT.TAGGED_FOLLOWING (s, tag) ->
 269           LOOP_TAG((Tree.tagged_following_before tree t tag ctx), s, tag, ctx)
 270
 271         | L2JIT.SELECT_DESCENDANT (s, _, us) ->
 272           LOOP((Tree.select_descendant tree t us), s, ctx)
 273
 274         | L2JIT.SELECT_FOLLOWING (s, pt, us) ->
 275           LOOP ((Tree.select_following_before tree t us ctx), s, ctx)
 276
 277         | L2JIT.TAGGED_CHILD (s, tag) ->
 278           LOOP_TAG((Tree.tagged_child tree t tag), s, tag, ctx)
 279
 280         | L2JIT.TAGGED_FOLLOWING_SIBLING (s, tag) ->
 281           LOOP_TAG((Tree.tagged_following_sibling tree t tag), s, tag, ctx)
 282
 283         | L2JIT.SELECT_CHILD (s, _, us) ->
 284           LOOP ((Tree.select_child tree t us), s, ctx)
 285
 286         | L2JIT.SELECT_FOLLOWING_SIBLING (s, _, us) ->
 287           LOOP ((Tree.select_following_sibling tree t us), s, ctx)
 288
 289         | L2JIT.TAGGED_SUBTREE(s, tag) ->
 290           mark_subtree s (U.NS.subtree_tags tree t tag)
 291
 292         | L2JIT.ELEMENT_SUBTREE(s) ->
 293           mark_subtree s (U.NS.subtree_elements tree t)
 294       in
 295       let r = LOOP (root, states, ctx) in
 296       (*L3JIT.stats err_formatter cache3; *)
 297       r
 298
 299     let full_top_down_run auto states tree root =
 300       (*Ata.init (); *)
 301       top_down_run auto tree root states (Tree.closing tree root)
 302
 303     let top_down_run auto tree root =
 304       (*Ata.init (); *)
 305       let res, slot = full_top_down_run auto auto.init tree root in
 306
 307       slot.(StateSet.min_elt auto.topdown_marking_states)
 308
 309
 310     (*** Bottom-up evaluation function **)
 311
 312     let eval_trans auto tree parent res1 res2 = assert false
 313
 314     let rec uniq = function
 315       | ([] | [ _ ]) as l -> l
 316       | e1 :: ((e2 :: ll) as l) -> if e1 == e2 then uniq l
 317         else e1 :: e2 :: (uniq ll);;
 318
 319 DEFINE BOTTOM_UP_NEXT(node, rest, stop) =
 320       (let ___fs = Tree.first_child tree node in
 321        let ___res1 =
 322          if ___fs == Tree.nil then nil_res
 323          else full_top_down_run auto states tree ___fs
 324        in
 325        move_up node ___res1 true rest stop)
 326
 327
 328     let bottom_up_run auto tree (query, pat) =
 329       let array = time ~msg:"Timing text query" (Tree.full_text_query query tree) pat in
 330       let leaves = Array.to_list array in
 331       let states = auto.states in
 332       let res_len = (StateSet.max_elt states) + 1 in
 333       let empty_slot = Array.create res_len U.NS.empty in
 334       let nil_res = auto.bottom_states, empty_slot in
 335       let cache = Cache.Lvl3.create 0 L3JIT.dummy in
 336       let rec move_up node res is_left rest stop =
 337         if node == stop then res, rest
 338         else
 339           (*let prev_sibling = Tree.prev_sibling tree node in *)
 340           let is_left' = Tree.is_first_child tree node (*prev_sibling == Tree.nil*) in
 341           (*TODO: unsound in case of following-sibling moves
 342             should replace the else by previous_sibling and walk up the sequence of
 343             right child moves *)
 344           let parent = if is_left' then Tree.parent tree node else
 345               let p = Tree.first_child tree (Tree.parent tree node) in
 346               if p < stop then stop else p
 347           in
 348           let (s1, sl1), (s2, sl2), rest' =
 349             if is_left then match rest with
 350                 [] -> res, nil_res, rest
 351               | next :: rest' ->
 352                 if Tree.is_right_descendant tree node next
 353                 then
 354                   let res2, rest' = (*bottom_up_next*) BOTTOM_UP_NEXT(next, rest', node) in
 355                   res, res2, rest'
 356                 else res, nil_res, rest
 357             else
 358               nil_res, res, rest
 359           in
 360           let tag = Tree.tag tree node in
 361           let id1 = Uid.to_int s1.StateSet.Node.id in
 362           let id2 = Uid.to_int s2.StateSet.Node.id in
 363           let code =
 364             let code = Cache.Lvl3.find cache id2 id1 tag in
 365             if code == L3JIT.dummy  then
 366               let trl =
 367                 StateSet.fold
 368                   (fun q acc ->
 369                     List.fold_left (fun acc' (labels, tr) ->
 370                       if TagSet.mem tag labels
 371                       then Translist.cons tr acc' else acc')
 372                       acc
 373                       (Hashtbl.find auto.trans q)
 374                   )
 375                   states
 376                   Translist.nil
 377               in
 378               let code = L3JIT.gen_code auto trl s1 s2 in
 379               Cache.Lvl3.add cache id2 id1 tag code; code
 380             else code
 381           in
 382           let res' = code empty_slot sl1 sl2 tree node in
 383           move_up parent res' is_left' rest' stop
 384       in
 385       let loop_leaves l =
 386         match l with
 387           [] -> nil_res
 388         | node :: ll ->
 389           let res, lll = BOTTOM_UP_NEXT( (*bottom_up_next*) node, ll, Tree.nil) in
 390           if lll <> [] then
 391             Logger.print err_formatter "WARNING: Leftover nodes: %i\n" (List.length lll);
 392           res
 393       in
 394     let _, slot = loop_leaves leaves in
 395     slot.(StateSet.min_elt auto.topdown_marking_states)
 396
 397
 398 let get_trans g auto tag states =
 399   StateSet.fold (fun q tr_acc ->
 400     List.fold_left
 401       (fun ((lstates, rstates, tacc) as acc) (ts, trs) ->
 402         if TagSet.mem (Tag.translate tag) ts then
 403           if not (TagSet.mem Tag.attribute ts) && Grammar2.is_attribute g tag
 404           then acc
 405               else
 406             let _, _, _, phi = Transition.node trs in
 407                 let l, r = Formula.st phi in
 408                 (StateSet.union l lstates,
 409                  StateSet.union r rstates,
 410                  Translist.cons trs tacc)
 411         else acc)
 412       tr_acc (Hashtbl.find auto.trans q)
 413   ) states (StateSet.empty, StateSet.empty, Translist.nil)
 414
 415 (*  Grammar run *)
 416 let dispatch_param0 conf id2 y0 y1 =
 417   match conf with
 418   | Grammar2.C0 | Grammar2.C2 -> Grammar2.Node0 id2
 419   | Grammar2.C1 | Grammar2.C5 -> Grammar2.Node1(id2,y0)
 420   | Grammar2.C3 | Grammar2.C6 -> y0
 421   | Grammar2.C4 -> Grammar2.Node2(id2, y0, y1)
 422
 423 let dispatch_param1 conf id2 y0 y1 =
 424   match conf with
 425   | Grammar2.C2 -> y0
 426   | Grammar2.C3 -> Grammar2.Node0 id2
 427   | Grammar2.C5 -> y1
 428   | Grammar2.C6 -> Grammar2.Node1(id2, y1)
 429   | _ -> Grammar2.dummy_param
 430
 431     module K_down = struct
 432       type t = Grammar2.n_symbol * StateSet.t
 433       let hash (x,y) = HASHINT2(Node.to_int x, Uid.to_int y.StateSet.Node.id)
 434       let equal (x1,y1) (x2,y2) = x1 == x2 && y1 == y2
 435     end
 436
 437     module K_up = struct
 438       type t = Grammar2.n_symbol * StateSet.t * StateSet.t * StateSet.t
 439       let hash (a,b,c,d) =
 440         HASHINT4 (Node.to_int a,
 441                   Uid.to_int b.StateSet.Node.id,
 442                   Uid.to_int c.StateSet.Node.id,
 443                   Uid.to_int d.StateSet.Node.id)
 444       let equal (a1, b1, c1, d1) (a2, b2, c2, d2) =
 445         a1 == a2 && b1  == b2 && c1 == c2 && d1 == d2
 446     end
 447
 448     module DCache =
 449       struct
 450         include Hashtbl.Make(K_down)
 451         let dummy = StateSet.singleton State.dummy
 452         let notfound l = l.(0) == dummy && l.(1) == dummy
 453         let find h k =
 454           try
 455             find h k
 456           with
 457             Not_found ->
 458               let a = [| dummy; dummy |] in
 459               add h k a;
 460               a
 461       end
 462     module UCache = Hashtbl.Make(K_up)
 463     type result = {
 464       in0 : StateSet.t;
 465       in1 : StateSet.t;
 466       out0 : StateSet.t * U.t;
 467       out1 : StateSet.t * U.t;
 468       main : StateSet.t * U.t
 469     }
 470     let mk_empty e =
 471       { in0 = StateSet.empty;
 472         in1 = StateSet.empty;
 473         out0 = e;
 474         out1 = e;
 475         main = e
 476       }
 477     let mk_nil s v  =
 478       {
 479         mk_empty (s,v) with
 480           out0 = StateSet.empty,v;
 481           out1 = StateSet.empty,v;
 482       }
 483
 484     let grammar_run auto g () =
 485       let dummy_leaf = Grammar2.dummy_param in
 486       let dummy_set = StateSet.singleton State.dummy in
 487       let res_len = (StateSet.max_elt auto.states) + 1 in
 488       let empty_slot = Array.create res_len U.NS.empty in
 489       let nil_res = mk_nil auto.bottom_states empty_slot in
 490       let cache3 = L3JIT.create () in
 491       let dummy2 = (StateSet.empty, StateSet.empty, Translist.nil) in
 492       let cache2 = Cache.Lvl2.create 512 dummy2 in
 493       let rule_counter = ref 0 in
 494       let preorder_counter = ref 0 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