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
15 module Make (U : ResJIT.S) : S with type result_set = U.NS.t =
18 type result_set = U.NS.t;;
20 let eval_form auto s1 s2 f =
22 match Formula.expr f with
23 | Formula.False | Formula.True | Formula.Pred _ -> f, []
24 | Formula.Atom(`Left, b, q) ->
25 Formula.of_bool (b == (StateSet.mem q s1)),
26 if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.LEFT q] else []
27 | Formula.Atom (`Right, b, q) ->
28 Formula.of_bool(b == (StateSet.mem q s2)),
29 if b && StateSet.mem q auto.topdown_marking_states then [ResJIT.RIGHT q] else []
30 | Formula.Atom (`Epsilon, _, _) -> assert false
32 | Formula.Or(f1, f2) ->
33 let b1, i1 = loop f1 in
34 let b2, i2 = loop f2 in
35 Formula.or_pred b1 b2, i1 @ i2
36 | Formula.And(f1, f2) ->
37 let b1, i1 = loop f1 in
38 let b2, i2 = loop f2 in
39 Formula.and_pred b1 b2, i1 @ i2
44 let eval_trans auto s1 s2 trans =
46 (fun t ((a_st, a_op, a_todo) as acc)->
47 let q, _, m, f = Transition.node t in
48 let form, ops = eval_form auto s1 s2 f in
49 match Formula.expr form with
52 (q, (if m then (ResJIT.SELF() :: ops) else ops)):: a_op,
54 | Formula.False -> acc
55 | Formula.Pred p -> a_st, a_op,
56 (p.Tree.Predicate.node, q, [(q,(if m then (ResJIT.SELF() :: ops) else ops))]) :: a_todo
58 ) trans (StateSet.empty, [], [])
65 type opcode = (t -> t -> t -> Tree.t -> Tree.node -> StateSet.t * t)
67 type t = opcode Cache.t Cache.t Cache.t
69 let dummy _ _ _ _ _ = failwith "Uninitialized L3JIT"
71 let create () = Cache.Lvl3.create 1024 dummy
74 let d = Cache.Lvl3.to_array d in
75 let len = Array.fold_left
77 Array.fold_left (fun acc2 a2 -> Array.length a2 + acc2) acc a) 0 d
82 (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
83 let lvl2 = Array.fold_left
85 Array.fold_left (fun acc2 a2 -> if Array.length a2 == 0 then acc2 else acc2+1)
88 let lvl3 = Array.fold_left
90 Array.fold_left (fun acc2 a2 ->
92 (fun acc3 a3 -> if a3 != dummy then acc3+1 else acc3)
96 fprintf fmt "L3JIT Statistics:
101 \ttable size: %ikb\n"
102 len lvl1 lvl2 lvl3 (Ocaml.size_kb d)
104 let find t tlist s1 s2 =
106 (Uid.to_int tlist.Translist.Node.id)
107 (Uid.to_int s1.StateSet.Node.id)
108 (Uid.to_int s2.StateSet.Node.id)
110 let add t tlist s1 s2 v =
112 (Uid.to_int tlist.Translist.Node.id)
113 (Uid.to_int s1.StateSet.Node.id)
114 (Uid.to_int s2.StateSet.Node.id)
117 let compile auto trl s1 s2 =
118 let orig_s1, orig_s2 =
119 Translist.fold (fun t (a1, a2) ->
120 let _, _, _, f = Transition.node t in
121 let (_, _, fs1), (_, _, fs2) = Formula.st f in
122 (StateSet.union a1 fs1, StateSet.union a2 fs2)
123 ) trl (StateSet.empty, StateSet.empty)
125 let ns1 = StateSet.inter s1 orig_s1
126 and ns2 = StateSet.inter s2 orig_s2 in
127 let res, ops, todo = eval_trans auto ns1 ns2 trl in
128 let code, not_marking = ResJIT.compile ops in
129 let todo_code, todo_notmarking =
130 List.fold_left (fun (l, b) (p, q, o) -> let c, b' = ResJIT.compile o in
131 (p, q, c)::l, b && b')
132 ([], not_marking) todo
134 let opcode = res, code, todo_notmarking, todo_code in
137 let gen_code auto tlist s1 s2 =
138 let res, code, not_marking, todo_code = compile auto tlist s1 s2 in
140 if todo_code == [] then
141 if not_marking then begin fun empty_slot sl1 sl2 _ node ->
142 let slot1_empty = sl1 == empty_slot
143 and slot2_empty = sl2 == empty_slot in
144 if slot1_empty && slot2_empty then res,sl2
149 Array.copy empty_slot
153 U.exec sl sl1 sl2 node code;
156 else (* marking *) begin fun empty_slot sl1 sl2 _ node ->
158 if sl2 == empty_slot then
159 if sl1 == empty_slot then
160 Array.copy empty_slot
164 U.exec sl sl1 sl2 node code;
167 else (* todo != [] *)
168 begin fun empty_slot sl1 sl2 tree node ->
170 if sl2 == empty_slot then
171 if sl1 == empty_slot then
172 Array.copy empty_slot
176 U.exec sl sl1 sl2 node code;
178 (fun ares (p, q, code) ->
179 if !p tree node then begin
180 if code != ResJIT.Nil then U.exec sl sl1 sl2 node code;
183 else ares) res todo_code, sl
189 let cache_apply cache auto tlist s1 s2 =
190 let f = gen_code auto tlist s1 s2 in
191 TRACE("grammar", 2, __ "Inserting: %i, %a, %a\n%!"
192 (Uid.to_int tlist.Translist.Node.id) StateSet.print s1 StateSet.print s2);
193 add cache tlist s1 s2 f; f
196 DEFINE LOOP (t, states, ctx) = (
198 TRACE("top-down-run", 3,
199 __ "Entering node %i with loop (tag %s, context %i) with states %a\n%!"
201 (Tag.to_string (Tree.tag tree _t))
203 (StateSet.print) (states));
204 if _t == Tree.nil then nil_res
206 let tag = Tree.tag tree _t in
208 _t tag (states) (ctx) (L2JIT.find cache2 tag (states))
211 DEFINE LOOP_TAG (t, states, tag, ctx) = (
212 let _t = (t) in (* to avoid duplicating expression t *)
213 TRACE("top-down-run", 3,
214 __ "Entering node %i with loop_tag (tag %s, context %i) with states %a\n%!"
216 (Tag.to_string (tag))
218 (StateSet.print) (states));
219 if _t == Tree.nil then nil_res
222 _t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states)))
224 let top_down_run auto tree root states ctx =
225 let res_len = (StateSet.max_elt auto.states) + 1 in
226 let empty_slot = Array.create res_len U.NS.empty in
227 let nil_res = auto.bottom_states, empty_slot in
228 let cache3 = L3JIT.create () in
230 let l3jit_dispatch trl s1 s2 t sl1 sl2 =
231 let f = L3JIT.find cache3 trl s1 s2 in
232 if f == L3JIT.dummy then (L3JIT.cache_apply cache3 auto trl s1 s2) empty_slot sl1 sl2 tree t
233 else f empty_slot sl1 sl2 tree t
236 let cache2 = L2JIT.create () in
238 let () = D_TRACE_(at_exit (fun () -> L2JIT.stats Format.err_formatter cache2)) in
240 let rec l2jit_dispatch t tag states ctx opcode =
242 | L2JIT.RETURN () -> nil_res
244 let opcode = L2JIT.compile cache2 auto tree tag states in
245 l2jit_dispatch t tag states ctx opcode
247 | L2JIT.LEFT (tr_list, instr) ->
249 l2jit_dispatch_instr t tag states (Tree.closing tree t) instr true
251 l3jit_dispatch tr_list res1 auto.bottom_states t slot1 empty_slot
253 | L2JIT.RIGHT (tr_list, instr) ->
254 let res2, slot2 = l2jit_dispatch_instr t tag states ctx instr false in
255 l3jit_dispatch tr_list auto.bottom_states res2 t empty_slot slot2
257 | L2JIT.BOTH (tr_list, instr1, instr2) ->
259 l2jit_dispatch_instr t tag states (Tree.closing tree t) instr1 true
261 let res2, slot2 = l2jit_dispatch_instr t tag states ctx instr2 false in
262 l3jit_dispatch tr_list res1 res2 t slot1 slot2
264 and l2jit_dispatch_instr t tag states ctx instr _left =
266 | L2JIT.NOP () -> nil_res
267 | L2JIT.FIRST_CHILD s -> LOOP ((Tree.first_child tree t), s, ctx)
268 | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_sibling tree t), s, ctx)
269 (* | L2JIT.NEXT_SIBLING s -> LOOP ((Tree.next_node_before tree t ctx), s, ctx) *)
271 | L2JIT.FIRST_ELEMENT s -> LOOP ((Tree.first_element tree t), s, ctx)
272 | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_element tree t), s, ctx)
273 (* | L2JIT.NEXT_ELEMENT s -> LOOP ((Tree.next_node_before tree t ctx), s, ctx) *)
275 | L2JIT.TAGGED_DESCENDANT (s, tag) ->
276 LOOP_TAG ((Tree.tagged_descendant tree t tag), s, tag, ctx)
278 | L2JIT.TAGGED_FOLLOWING (s, tag) ->
279 LOOP_TAG((Tree.tagged_following_before tree t tag ctx), s, tag, ctx)
281 | L2JIT.SELECT_DESCENDANT (s, _, us) ->
282 LOOP((Tree.select_descendant tree t us), s, ctx)
284 | L2JIT.SELECT_FOLLOWING (s, pt, us) ->
285 LOOP ((Tree.select_following_before tree t us ctx), s, ctx)
287 | L2JIT.TAGGED_CHILD (s, tag) ->
288 LOOP_TAG((Tree.tagged_child tree t tag), s, tag, ctx)
290 | L2JIT.TAGGED_FOLLOWING_SIBLING (s, tag) ->
291 LOOP_TAG((Tree.tagged_following_sibling tree t tag), s, tag, ctx)
293 | L2JIT.SELECT_CHILD (s, _, us) ->
294 LOOP ((Tree.select_child tree t us), s, ctx)
296 | L2JIT.SELECT_FOLLOWING_SIBLING (s, _, us) ->
297 LOOP ((Tree.select_following_sibling tree t us), s, ctx)
299 | L2JIT.TAGGED_SUBTREE(s, tag) ->
301 let count = U.NS.subtree_tags tree t tag in
302 if count != U.NS.empty then
303 let r = Array.copy empty_slot in
304 r.(auto.last) <- count;
309 | L2JIT.ELEMENT_SUBTREE(s) ->
311 let count = U.NS.subtree_elements tree t in
312 if count != U.NS.empty then
313 let r = Array.copy empty_slot in
314 r.(auto.last) <- count;
320 let r = LOOP (root, states, ctx) in
321 (*L3JIT.stats err_formatter cache3; *)
324 let full_top_down_run auto states tree root =
326 top_down_run auto tree root states (Tree.closing tree root)
328 let top_down_run auto tree root =
330 let res, slot = full_top_down_run auto auto.init tree root in
332 slot.(StateSet.min_elt auto.topdown_marking_states)
335 (*** Bottom-up evaluation function **)
338 Format.fprintf fmt "{ ";
339 U.NS.iter begin fun node ->
340 Format.fprintf fmt "%a " Node.print node;
342 Format.fprintf fmt "}"
344 let slot_print fmt t =
345 Array.iteri begin fun state ns ->
346 Format.eprintf "%a -> %a\n" State.print state ns_print ns;
350 let eval_trans auto tree parent res1 res2 = assert false
353 let bottom_up_run auto tree (query, pat) =
354 let leaves = Array.to_list (Tree.full_text_query query tree pat) in
355 let states = auto.states in
356 let res_len = (StateSet.max_elt states) + 1 in
357 let empty_slot = Array.create res_len U.NS.empty in
358 let nil_res = auto.bottom_states, empty_slot in
359 let cache = Cache.Lvl3.create 1024 L3JIT.dummy in
360 let rec loop_leaves l acc =
364 let res, lll = bottom_up_next node ll Tree.nil in
365 if (lll <> []) then Printf.eprintf "Leftover elements\n%!";
368 and bottom_up_next node rest stop =
369 let fs = Tree.first_child tree node in
371 if fs == Tree.nil then nil_res
372 else full_top_down_run auto states tree fs
374 move_up node res1 true rest stop
376 and move_up node res is_left rest stop =
377 if node == stop then res, rest
379 let prev_sibling = Tree.prev_sibling tree node in
380 let is_left' = prev_sibling == Tree.nil in
381 let real_parent = Tree.parent tree node in
383 if is_left' then real_parent else max (Tree.first_child tree real_parent) stop
385 (* let parent = if is_left' then Tree.parent tree node else prev_sibling in *)
386 let (s1, sl1), (s2, sl2), rest' =
387 if is_left then match rest with
388 [] -> res, nil_res, rest
390 if Tree.is_right_descendant tree node next
392 let res2, rest' = bottom_up_next next rest' node in
394 else res, nil_res, rest
398 let tag = Tree.tag tree node in
399 let id1 = Uid.to_int s1.StateSet.Node.id in
400 let id2 = Uid.to_int s2.StateSet.Node.id in
402 let code = Cache.Lvl3.find cache tag id1 id2 in
403 if code == L3JIT.dummy then
407 List.fold_left (fun acc' (labels, tr) ->
408 if labels == TagSet.any || TagSet.mem tag labels
409 then Translist.cons tr acc' else acc')
411 (Hashtbl.find auto.trans q)
416 let code = L3JIT.gen_code auto trl s1 s2 in
417 Cache.Lvl3.add cache tag id1 id2 code; code
420 let res' = code empty_slot sl1 sl2 tree node in
421 move_up parent res' is_left' rest' stop
423 let _, slot = loop_leaves leaves (nil_res) in
424 slot.(StateSet.min_elt auto.topdown_marking_states)
429 external is_young : 'a array -> bool = "caml_custom_is_young" "noalloc"
430 external blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_custom_array_blit"
431 module M = Map.Make(struct type t = Grammar.n_symbol let compare = compare end)
432 let log = ref M.empty
434 let c = try M.find s !log with _ -> 0 in
435 log:= M.add s (c+1) !log
437 let () = at_exit (fun () -> M.iter (fun i j ->
439 Printf.eprintf "%i->%i\n%!"
440 (Grammar.symbol i) j) !log )
442 let blit a1 o1 a2 o2 l = if l != 0 then
443 for i = 0 to l - 1 do
444 a2.(o2 + i) <- a1.(o1 + i);
448 let grammar_run auto g () =
450 let dummy_leaf = Grammar2.Leaf (Node.nil) in
451 let res_len = (StateSet.max_elt auto.states) + 1 in
452 let empty_slot = Array.create res_len U.NS.empty in
453 let nil_res = auto.bottom_states, empty_slot in
454 let empty_res = StateSet.empty, empty_slot in
455 let cache3 = L3JIT.create () in
456 let dummy2 = (StateSet.empty, StateSet.empty, Translist.nil) in
457 let cache2 = Cache.Lvl2.create 512 dummy2 in
458 let parameters = Array.create 2 dummy_leaf in
459 let parameters_tmp = Array.create 2 dummy_leaf in
460 let rule_counter = ref 0 in
461 let start_counter = ref 0 in
462 let () = at_exit (fun () -> Printf.eprintf "start_couter=%i, rule_counter=%i\n%!"
463 !start_counter !rule_counter) in
464 let get_trans tag states =
465 let c = Cache.Lvl2.find cache2 tag (Uid.to_int states.StateSet.Node.id) in
468 StateSet.fold (fun q tr_acc ->
470 (fun ((lstates, rstates, tacc) as acc) (ts, trs) ->
471 if TagSet.mem (Tag.translate tag) ts then
472 let _, _, _, phi = Transition.node trs in
473 let (_,_,l),(_,_,r) = Formula.st phi in
474 (StateSet.union l lstates,
475 StateSet.union r rstates,
476 Translist.cons trs tacc)
478 tr_acc (Hashtbl.find auto.trans q)
479 ) states (StateSet.empty, StateSet.empty, Translist.nil)
482 Cache.Lvl2.add cache2 tag (Uid.to_int states.StateSet.Node.id) c;
487 let rec start_loop idx states =
488 incr (start_counter);
489 TRACE("grammar", 2, __ "Node %i\n%!" (Node.to_int idx));
490 if idx < Node.null then nil_res
491 else if StateSet.is_empty states then empty_res
493 let symbol = Grammar2.start_tag g idx in
494 if Grammar2.is_terminal g symbol then
495 let symbol = Grammar2.terminal symbol in
496 if symbol == Grammar2.nil_symbol then nil_res else
497 let tag = Grammar2.tag symbol in
498 let lst, rst, trans = get_trans tag states in
499 let fs = Grammar2.start_first_child g idx in
500 let s1, slot1 = start_loop fs lst in
501 let s2, slot2 = start_loop (Grammar2.start_next_sibling g fs) rst in
502 let opcode = L3JIT.find cache3 trans s1 s2 in
503 if opcode == L3JIT.dummy then
504 (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic ())
505 else opcode empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic())
507 let nt = Grammar2.non_terminal symbol in
508 let rhs = Grammar2.get_rule g nt in
509 let nparam = Grammar2.get_rank rhs in
510 let child = ref (Grammar2.start_first_child g idx) in
511 for i = 0 to nparam - 1 do
513 parameters.(i) <- Grammar2.Leaf c;
514 child := Grammar2.start_next_sibling g c;
516 rule_loop nt states parameters
519 and rule_loop (t : Grammar2.n_symbol) states a_param =
521 if !rule_counter land (4095) == 0 then begin Gc.minor() end;
522 let rhs = Grammar2.get_rule g t in
523 let id1 = Grammar2.get_id1 rhs in
524 let id2 = Grammar2.get_id2 rhs in
525 let param_pos = Grammar2.get_id2_pos rhs in
526 let nparam1 = Grammar2.get_id1_rank rhs in
527 let nparam2 = Grammar2.get_id2_rank rhs in
528 let a_param2 = if nparam2 == 0 then [||] else Array.create nparam2 dummy_leaf in
529 let i = param_pos - 2 in
531 let offset2d = i+2 in
532 let offset2s = i+nparam2 + 1 in
533 blit a_param 0 parameters_tmp 0 (i+1);
534 parameters_tmp.(ip1) <- Grammar2.Node(id2, a_param2); (* id2( ... ) *)
535 blit a_param offset2s parameters_tmp offset2d (nparam1 - i - 2);
536 blit a_param ip1 a_param2 0 nparam2;
538 blit parameters_tmp 0 parameters 0 nparam1;
539 if Grammar2.is_non_terminal g id1 then
540 let id1 = Grammar2.non_terminal id1 in
541 rule_loop id1 states parameters
543 let id1 = Grammar2.terminal id1 in
544 terminal_loop id1 states parameters
546 and terminal_loop (symbol : Grammar2.t_symbol) states a_param =
547 if symbol == Grammar2.nil_symbol then nil_res else begin
548 (* todo factor in from start_loop *)
549 let tag = Grammar2.tag symbol in
550 let lst, rst, trans = get_trans tag states in
551 let next = a_param.(1) in
552 let s1, slot1 = partial_loop a_param.(0) lst in
553 let s2, slot2 = partial_loop next rst in
554 let opcode = L3JIT.find cache3 trans s1 s2 in
555 if opcode == L3JIT.dummy then
556 (L3JIT.cache_apply cache3 auto trans s1 s2) empty_slot slot1 slot2 (Obj.magic ()) (Obj.magic ())
558 opcode empty_slot slot1 slot2 (Obj.magic()) (Obj.magic())
562 and partial_loop l states =
564 | Grammar2.Leaf id -> start_loop id states
565 | Grammar2.Node (id, a_param) ->
566 let is_term = Grammar2.is_terminal g id in
568 terminal_loop (Grammar2.terminal id) states a_param
570 rule_loop (Grammar2.non_terminal id) states a_param
573 let _, slot = start_loop (Node.null) auto.init in
574 slot.(StateSet.min_elt auto.topdown_marking_states)