Clean-up Hcons module:

[SXSI/xpathcomp.git] / src / l2JIT.ml

diff --git a/src/l2JIT.ml b/src/l2JIT.ml
index 6eccae3..90be37f 100644 (file)
--- a/src/l2JIT.ml
+++ b/src/l2JIT.ml
@@ -1,5 +1,6 @@
 INCLUDE "debug.ml"
 INCLUDE "utils.ml"
+INCLUDE "trace.ml"
 
 open Format
 open Ata
@@ -85,21 +86,22 @@ let jump_stat_summary fmt =
 
 
 type opcode =
-  | CACHE of unit
-  | RETURN of unit
+  | CACHE
+  | RETURN
   | LEFT of Translist.t * jump
   | RIGHT of Translist.t * jump
   | BOTH of Translist.t * jump * jump
 
 type t = opcode Cache.Lvl2.t
-let dummy = CACHE()
+
+let dummy = CACHE
 let print_opcode fmt o = match o with
-  | CACHE _ -> fprintf fmt "CACHE()"
-  | RETURN _ -> fprintf fmt "RETURN ()"
+  | CACHE  -> fprintf fmt "CACHE"
+  | RETURN  -> fprintf fmt "RETURN"
   | LEFT (tl, j) -> fprintf fmt "LEFT(\n[%a], %a)" Translist.print tl print_jump j
   | RIGHT (tl, j) -> fprintf fmt "RIGHT(\n[%a], %a)" Translist.print tl print_jump j
   | BOTH (tl, j1, j2) -> fprintf fmt "BOTH(\n[%a], %a, %a)" Translist.print tl print_jump j1 print_jump j2
-
+(*
 let print_cache fmt d =
   let c = Cache.Lvl2.to_array d in
   Array.iteri begin fun tag a ->
@@ -113,9 +115,9 @@ let print_cache fmt d =
       fprintf fmt "---------------------------\n%!"
     end
   end c
-
-let create () = Cache.Lvl2.create 1024 dummy
-
+*)
+let create () = Cache.Lvl2.create 4096 dummy
+(*
 let stats fmt c =
   let d = Cache.Lvl2.to_array c in
   let len = Array.fold_left (fun acc a -> Array.length a + acc) 0 d in
@@ -132,10 +134,11 @@ let stats fmt c =
       len lvl1 lvl2 (Ocaml.size_kb d);
   fprintf fmt "%s" "L2JIT Content:\n";
   print_cache fmt c
+*)
 
-let find t tag set = Cache.Lvl2.find t tag (Uid.to_int set.StateSet.Node.id)
+let find t tag set = Cache.Lvl2.find t (Uid.to_int set.StateSet.Node.id) tag
 
-let add t tag set v = Cache.Lvl2.add t tag (Uid.to_int set.StateSet.Node.id) v
+let add t tag set v = Cache.Lvl2.add t (Uid.to_int set.StateSet.Node.id) tag v
 
 let collect_trans tag ((a_t, a_s1, a_s2) as acc) (labels, tr) =
   if TagSet.mem tag labels
@@ -168,8 +171,8 @@ let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
          let labels = Ptset.Int.inter l_one t in
          let c = Ptset.Int.cardinal labels in
            if c == 0 then _nop
-           else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels
-           then translate_jump tree tag (JUMP_MANY(labels)) dir s
+           else if Ptset.Int.for_all (fun lab -> not (Ptset.Int.mem lab l_many)) labels then
+             translate_jump tree tag (JUMP_MANY(labels)) dir s
            else if c == 1 then tagged_one s (Ptset.Int.choose labels)
            else if c > 5 then if has_text labels then any s else any_notext s
            else select_one s labels
@@ -195,22 +198,22 @@ let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
       | _ -> assert false
 
 let compute_jump auto tree tag states dir =
-  (*PROF_CFUN("L2JIT.compute_jump"); *)
   if !Options.no_jump then
     if dir == DIR_LEFT then FIRST_CHILD states
     else NEXT_SIBLING states
   else
     let jkind = Ata.top_down_approx auto states tree in
     let jump = translate_jump tree tag jkind dir states in
-      D_TRACE_(eprintf "Computed jumps for %s %a %s: %a\n%!"
-                (Tag.to_string tag)
-                StateSet.print states
-                (if dir == DIR_LEFT then "left" else "right")
-                print_jump jump);
-      jump
+      TRACE("level2-jit", 2,
+           __ "Computed jumps for %s %a %s: %a\n%!"
+             (Tag.to_string tag)
+             StateSet.print states
+             (if dir == DIR_LEFT then "left" else "right")
+             print_jump jump
+      );
+    jump
 
 let compile cache2 auto tree tag states =
-  (*PROF_CFUN("L2JIT.compile"); *)
   let tr_list, states1, states2 =
     StateSet.fold
       (fun q acc ->
@@ -223,7 +226,7 @@ let compile cache2 auto tree tag states =
   let op =
     let empty_s1 = StateSet.is_empty states1 in
     let empty_s2 = StateSet.is_empty states2 in
-      if empty_s1 && empty_s2 then RETURN ()
+      if empty_s1 && empty_s2 then RETURN
       else if empty_s1 then
        RIGHT (tr_list,
               compute_jump auto tree tag states2 DIR_RIGHT)
@@ -231,9 +234,9 @@ let compile cache2 auto tree tag states =
        LEFT (tr_list,
              compute_jump auto tree tag states1 DIR_LEFT)
       else
-       BOTH (tr_list,
-             compute_jump auto tree tag states1 DIR_LEFT,
-             compute_jump auto tree tag states2 DIR_RIGHT)
+       let j1 = compute_jump auto tree tag states1 DIR_LEFT in
+       let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
+       BOTH (tr_list, j1, j2);
   in
   let op = match op with
       (*BOTH(_, NOP _, NOP _) |  LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
@@ -246,7 +249,7 @@ let compile cache2 auto tree tag states =
     op
 
 let get_transitions = function
-  | CACHE _ | RETURN _ -> failwith "get_transitions"
+  | CACHE  | RETURN  -> failwith "get_transitions"
   | LEFT (tr, _)
   | RIGHT (tr, _)
   | BOTH (tr, _, _) -> tr