X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=src%2Fl2JIT.ml;h=b1fd4daf16d70602c13a37b79ee3bcde4ffd771a;hb=d8e8a2b5c08a980a440d9fc9f3ea27af7711b524;hp=6eccae3ba56445730a9cbdc4f6488ae89f13dc6e;hpb=4b52da1a20a4fe031930bb96d2ca46bec06dc529;p=SXSI%2Fxpathcomp.git

diff --git a/src/l2JIT.ml b/src/l2JIT.ml
index 6eccae3..b1fd4da 100644
--- a/src/l2JIT.ml
+++ b/src/l2JIT.ml
@@ -1,11 +1,11 @@
 INCLUDE "debug.ml"
 INCLUDE "utils.ml"
+INCLUDE "trace.ml"
 
 open Format
 open Ata
 
 type jump =
-  | NOP of unit
   | FIRST_CHILD of StateSet.t
   | NEXT_SIBLING of StateSet.t
   | FIRST_ELEMENT of StateSet.t
@@ -22,22 +22,21 @@ type jump =
   | ELEMENT_SUBTREE of StateSet.t
 
 type dir = DIR_LEFT | DIR_RIGHT
-
-let _nop = NOP ()
-let _first_child s = FIRST_CHILD s
-let _next_sibling s = NEXT_SIBLING s
-let _first_element s = FIRST_ELEMENT s
-let _next_element s = NEXT_ELEMENT s
-let _tagged_descendant s t = TAGGED_DESCENDANT(s,t)
-let _tagged_following s t = TAGGED_FOLLOWING(s,t)
-let _select_descendant s t = SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t)
-let _select_following s t = SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t)
-let _tagged_child s t = TAGGED_CHILD(s,t)
-let _tagged_following_sibling s t = TAGGED_FOLLOWING_SIBLING(s,t)
-let _select_child s t = SELECT_CHILD(s,t, Tree.unordered_set_of_set t)
-let _select_following_sibling s t = SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t)
-let _tagged_subtree s t = TAGGED_SUBTREE (s, t)
-let _element_subtree s = ELEMENT_SUBTREE s
+let _nop = None
+let _first_child s = Some (FIRST_CHILD s)
+let _next_sibling s = Some (NEXT_SIBLING s)
+let _first_element s = Some (FIRST_ELEMENT s)
+let _next_element s = Some (NEXT_ELEMENT s)
+let _tagged_descendant s t = Some (TAGGED_DESCENDANT(s,t))
+let _tagged_following s t = Some (TAGGED_FOLLOWING(s,t))
+let _select_descendant s t = Some (SELECT_DESCENDANT(s,t, Tree.unordered_set_of_set t))
+let _select_following s t = Some (SELECT_FOLLOWING(s,t, Tree.unordered_set_of_set t))
+let _tagged_child s t = Some (TAGGED_CHILD(s,t))
+let _tagged_following_sibling s t = Some (TAGGED_FOLLOWING_SIBLING(s,t))
+let _select_child s t = Some (SELECT_CHILD(s,t, Tree.unordered_set_of_set t))
+let _select_following_sibling s t = Some (SELECT_FOLLOWING_SIBLING(s,t, Tree.unordered_set_of_set t))
+let _tagged_subtree s t = Some (TAGGED_SUBTREE (s, t))
+let _element_subtree s = Some (ELEMENT_SUBTREE s)
 
 
 let jump_stat_table = Hashtbl.create 17
@@ -48,7 +47,6 @@ let jump_stat j =
 
 let print_jump fmt j =
   match j with
-    | NOP _ -> fprintf fmt "nop"
     | FIRST_CHILD _ -> fprintf fmt "first_child"
     | NEXT_SIBLING _ -> fprintf fmt "next_sibling"
     | FIRST_ELEMENT _ -> fprintf fmt "first_element"
@@ -85,63 +83,42 @@ 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 ->
-    let tagstr = Tag.to_string tag in
-    if a != Cache.Lvl2.dummy_line d && tagstr <> "<INVALID TAG>"
-    then begin
-      fprintf fmt "Entry %s: \n" tagstr;
-      Array.iter (fun o -> if o != dummy then begin
-	print_opcode fmt o;
-	fprintf fmt "\n%!" end) a;
-      fprintf fmt "---------------------------\n%!"
-    end
-  end c
-
-let create () = Cache.Lvl2.create 1024 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
-  let lvl1 = Array.fold_left (fun acc a -> if Array.length a == 0 then acc else acc+1) 0 d in
-  let lvl2 = Array.fold_left (fun acc a ->
-				Array.fold_left (fun acc2 a2 -> if a2 == dummy then acc2 else acc2+1)
-				  acc a) 0 d
-  in
-  fprintf fmt "L2JIT Statistics:
-\t%i entries
-\t%i used L1 lines
-\t%i used L2 lines
-\ttable size: %ikb\n"
-      len lvl1 lvl2 (Ocaml.size_kb d);
-  fprintf fmt "%s" "L2JIT Content:\n";
-  print_cache fmt c
+let show_stats a =
+  let count = ref 0 in
+  Cache.Lvl2.iteri (fun _ _ _ b -> if not b then incr count) a;
+  eprintf "%!L2JIT: %i used entries\n%!" !count
 
-let find t tag set = Cache.Lvl2.find t tag (Uid.to_int set.StateSet.Node.id)
+let create () =
+  let v = Cache.Lvl2.create 4096 dummy in
+  if !Options.verbose then
+    at_exit (fun () -> show_stats v);
+  v
 
-let add t tag set v = Cache.Lvl2.add t tag (Uid.to_int set.StateSet.Node.id) v
+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 (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
   then
     let _, _, _, f = Transition.node tr in
-    let (_, _, s1), (_, _, s2) = Formula.st f in
+    let  s1,  s2 = Formula.st f in
       (Translist.cons tr a_t,
        StateSet.union s1 a_s1,
        StateSet.union s2 a_s2)
@@ -152,11 +129,11 @@ let has_text l = Ptset.Int.mem Tag.pcdata l
 let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
   let child, desc, sib, fol = Tree.tags tree tag in
      match jkind, dir with
-      | NIL, _ -> _nop
-      | NODE, DIR_LEFT -> FIRST_CHILD s
-      | STAR, DIR_LEFT -> FIRST_ELEMENT s
-      | NODE, DIR_RIGHT -> NEXT_SIBLING s
-      | STAR, DIR_RIGHT -> NEXT_ELEMENT s
+      | NIL, _ -> None
+      | NODE, DIR_LEFT -> Some (FIRST_CHILD s)
+      | STAR, DIR_LEFT -> Some (FIRST_ELEMENT s)
+      | NODE, DIR_RIGHT -> Some (NEXT_SIBLING s)
+      | STAR, DIR_RIGHT -> Some (NEXT_ELEMENT s)
       | JUMP_ONE t, _ ->
 	  let l_one, l_many, tagged_one, select_one, any, any_notext =
 	    if dir = DIR_LEFT then
@@ -167,9 +144,9 @@ let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
 	  in
 	  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
+	    if c == 0 then None
+	    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
@@ -189,28 +166,37 @@ let rec translate_jump tree tag (jkind:Ata.jump_kind) dir s =
 	    else select_many s labels
 
       | CAPTURE_MANY (t), DIR_LEFT ->
-	  if Ptset.Int.is_singleton t then TAGGED_SUBTREE(s, Ptset.Int.choose t)
-	  else if t == Tree.element_tags tree then ELEMENT_SUBTREE s
+	  if Ptset.Int.is_singleton t then Some (TAGGED_SUBTREE(s, Ptset.Int.choose t))
+	  else if t == Tree.element_tags tree then Some (ELEMENT_SUBTREE s)
 	  else assert false
       | _ -> 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
+    if dir == DIR_LEFT then Some (FIRST_CHILD states)
+    else Some (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
+    translate_jump tree tag jkind dir states
+
+let mk_left tr_list j =
+  match j with
+    Some x -> LEFT(tr_list, x)
+  | _ -> RETURN
+
+let mk_right tr_list j =
+  match j with
+    Some x -> RIGHT(tr_list, x)
+  | _ -> RETURN
+
+let mk_both tr_list j1 j2 =
+  match j1, j2 with
+  | Some x1, Some x2 -> BOTH(tr_list, x1, x2)
+  | None, Some x -> RIGHT(tr_list,x)
+  | Some x, None -> LEFT(tr_list, x)
+  | None, None -> RETURN
 
 let compile cache2 auto tree tag states =
-  (*PROF_CFUN("L2JIT.compile"); *)
   let tr_list, states1, states2 =
     StateSet.fold
       (fun q acc ->
@@ -223,30 +209,23 @@ 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)
+	mk_right tr_list
+	  (compute_jump auto tree tag states2 DIR_RIGHT)
       else if empty_s2 then
-	LEFT (tr_list,
-	      compute_jump auto tree tag states1 DIR_LEFT)
+	mk_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)
-  in
-  let op = match op with
-      (*BOTH(_, NOP _, NOP _) |  LEFT(_, NOP _) | RIGHT(_, NOP _) -> RETURN() *)
-    | BOTH(tr, ((NOP _) as l) , NOP _) -> LEFT (tr, l)
-    | BOTH(tr, l, NOP _) -> LEFT (tr, l)
-    | BOTH(tr, NOP _, r) -> RIGHT (tr, r)
-    | _ -> op
+	let j1 = compute_jump auto tree tag states1 DIR_LEFT in
+	let j2 = compute_jump auto tree tag states2 DIR_RIGHT in
+	mk_both tr_list j1 j2
   in
     add cache2 tag states op;
     op
 
 let get_transitions = function
-  | CACHE _ | RETURN _ -> failwith "get_transitions"
+  | CACHE  | RETURN  -> failwith "get_transitions"
   | LEFT (tr, _)
   | RIGHT (tr, _)
   | BOTH (tr, _, _) -> tr