Optimize the bottom-up run using a Camlp4 macro instead of an

(un-inlined) recursive call.

diff --git a/src/runtime.ml b/src/runtime.ml
index ab30f27..bc771eb 100644 (file)
--- a/src/runtime.ml
+++ b/src/runtime.ml
@@ -200,6 +200,7 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = (
     l2jit_dispatch
       _t (tag) (states) (ctx) (L2JIT.find cache2 (tag) (states)))
 
+
     let top_down_run auto tree root states ctx =
       let res_len = StateSet.max_elt auto.states + 1 in
       let empty_slot = Array.create res_len U.NS.empty in
@@ -315,6 +316,15 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = (
       | e1 :: ((e2 :: ll) as l) -> if e1 == e2 then uniq l
        else e1 :: e2 :: (uniq ll);;
 
+DEFINE BOTTOM_UP_NEXT(node, rest, stop) =
+      (let ___fs = Tree.first_child tree node in
+       let ___res1 =
+        if ___fs == Tree.nil then nil_res
+        else full_top_down_run auto states tree ___fs
+       in
+       move_up node ___res1 true rest stop)
+
+
     let bottom_up_run auto tree (query, pat) =
       let array = time ~msg:"Timing text query" (Tree.full_text_query query tree) pat in
       let leaves = Array.to_list array in
@@ -322,43 +332,26 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = (
       let res_len = (StateSet.max_elt states) + 1 in
       let empty_slot = Array.create res_len U.NS.empty in
       let nil_res = auto.bottom_states, empty_slot in
-      let cache = Cache.Lvl3.create 1024 L3JIT.dummy in
-      let rec loop_leaves l acc =
-       match l with
-           [] -> acc
-         | node :: ll ->
-           let res, lll = bottom_up_next node ll Tree.nil in
-           if (lll <> []) then
-             begin
-               eprintf "Leftover nodes: %i\n" (List.length lll);
-             end;
-           res
-
-      and bottom_up_next node rest stop =
-       let fs = Tree.first_child tree node in
-       let res1 =
-         if fs == Tree.nil then nil_res
-         else full_top_down_run auto states tree fs
-       in
-       move_up node res1 true rest stop
-
-      and move_up node res is_left rest stop =
+      let cache = Cache.Lvl3.create 0 L3JIT.dummy in
+      let rec move_up node res is_left rest stop =
        if node == stop then res, rest
        else
-         let prev_sibling = Tree.prev_sibling tree node in
-         let is_left' = prev_sibling == Tree.nil in
-         let real_parent = Tree.parent tree node in
-         let parent =
-           if is_left' then real_parent else max (Tree.first_child tree real_parent) stop
+         (*let prev_sibling = Tree.prev_sibling tree node in *)
+         let is_left' = Tree.is_first_child tree node (*prev_sibling == Tree.nil*) in
+         (*TODO: unsound in case of following-sibling moves
+           should replace the else by previous_sibling and walk up the sequence of
+           right child moves *)
+         let parent = if is_left' then Tree.parent tree node else
+             let p = Tree.first_child tree (Tree.parent tree node) in
+             if p < stop then stop else p
          in
-         (* let parent = if is_left' then Tree.parent tree node else prev_sibling in *)
          let (s1, sl1), (s2, sl2), rest' =
            if is_left then match rest with
                [] -> res, nil_res, rest
              | next :: rest' ->
                if Tree.is_right_descendant tree node next
                then
-                 let res2, rest' = bottom_up_next next rest' node in
+                 let res2, rest' = (*bottom_up_next*) BOTTOM_UP_NEXT(next, rest', node) in
                  res, res2, rest'
                else res, nil_res, rest
            else
@@ -368,13 +361,13 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = (
          let id1 = Uid.to_int s1.StateSet.Node.id in
          let id2 = Uid.to_int s2.StateSet.Node.id in
          let code =
-           let code = Cache.Lvl3.find cache tag id1 id2 in
-           if code == L3JIT.dummy then
+           let code = Cache.Lvl3.find cache id2 id1 tag in
+           if code == L3JIT.dummy  then
              let trl =
                StateSet.fold
                  (fun q acc ->
                    List.fold_left (fun acc' (labels, tr) ->
-                     if labels == TagSet.any || TagSet.mem tag labels
+                     if TagSet.mem tag labels
                      then Translist.cons tr acc' else acc')
                      acc
                      (Hashtbl.find auto.trans q)
@@ -383,14 +376,24 @@ DEFINE LOOP_TAG (t, states, tag, ctx) = (
                  Translist.nil
              in
              let code = L3JIT.gen_code auto trl s1 s2 in
-             Cache.Lvl3.add cache tag id1 id2 code; code
+             Cache.Lvl3.add cache id2 id1 tag code; code
            else code
          in
          let res' = code empty_slot sl1 sl2 tree node in
          move_up parent res' is_left' rest' stop
       in
-      let _, slot = loop_leaves leaves (nil_res) in
-      slot.(StateSet.min_elt auto.topdown_marking_states)
+      let loop_leaves l =
+       match l with
+         [] -> nil_res
+       | node :: ll ->
+         let res, lll = BOTTOM_UP_NEXT( (*bottom_up_next*) node, ll, Tree.nil) in
+         if lll <> [] then
+           Logger.print err_formatter "WARNING: Leftover nodes: %i\n" (List.length lll);
+         res
+      in
+    let _, slot = loop_leaves leaves in
+    slot.(StateSet.min_elt auto.topdown_marking_states)
+
 
 let get_trans g auto tag states =
   StateSet.fold (fun q tr_acc ->