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