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