Major optimization, rewrite to avoid deep recursion if possible.

git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@810 3cdefd35-fc62-479d-8e8d-bae585ffb9ca

diff --git a/ata.ml b/ata.ml
index a291367..5288b78 100644 (file)
--- a/ata.ml
+++ b/ata.ml
@@ -709,13 +709,31 @@ THEN
 INCLUDE "html_trace.ml"
              
 END            
-      let mk_fun f s = D_IGNORE_(register_funname f s,f)
-      let mk_app_fun f arg s = let g = f arg in 
-       D_IGNORE_(register_funname g ((get_funname f) ^ " " ^ s), g) 
-      let mk_app_fun f arg _ = f arg 
-      let mk_app_fun2 f arg1 arg2 s = let g = f arg1 arg2 in 
-       D_IGNORE_(register_funname g ((get_funname f) ^ " " ^ s), g) 
-(*      let mk_app_fun2 f arg1 arg2 s = Printf.eprintf "Building f2 %s\n%!"  s; f arg1 arg2 *)
+      module Trace =
+      struct
+       module HFname = Hashtbl.Make (struct
+                                       type t = Obj.t
+                                       let hash = Hashtbl.hash
+                                       let equal = (==)
+                                     end)
+         
+       let h_fname = HFname.create 401
+         
+       let register_funname f s = 
+         HFname.add h_fname (Obj.repr  f) s
+       let get_funname f = try HFname.find h_fname  (Obj.repr f) with _ -> "[anon_fun]"
+
+
+
+       let mk_fun f s = register_funname f s;f
+       let mk_app_fun f arg s = 
+         let g = f arg in 
+         register_funname g ((get_funname f) ^ " " ^ s); g
+       let mk_app_fun2 f arg1 arg2 s = 
+         let g = f arg1 arg2 in 
+         register_funname g ((get_funname f) ^ " " ^ s); g 
+
+      end
 
       let string_of_ts tags = (Ptset.Int.fold (fun t a -> a ^ " " ^ (Tag.to_string t) ) tags "{")^ " }"
 
@@ -821,41 +839,41 @@ END
              if Ptset.Int.is_empty cl then
              if Ptset.Int.is_singleton ll then
              let tag = Ptset.Int.choose ll in 
-             (`TAG(tag),mk_app_fun f_tn tag (Tag.to_string tag))
+             (`TAG(tag),Trace.mk_app_fun f_tn tag (Tag.to_string tag))
              else
-             (`MANY(ll),mk_app_fun f_sn ll (string_of_ts ll))
+             (`MANY(ll),Trace.mk_app_fun f_sn ll (string_of_ts ll))
              else if Ptset.Int.is_empty ll then
              if Ptset.Int.is_singleton cl then
              let tag = Ptset.Int.choose cl in 
-             (`TAG(tag),mk_app_fun f_t1 tag (Tag.to_string tag))
+             (`TAG(tag),Trace.mk_app_fun f_t1 tag (Tag.to_string tag))
              else
-             (`MANY(cl),mk_app_fun f_s1 cl (string_of_ts cl))
+             (`MANY(cl),Trace.mk_app_fun f_s1 cl (string_of_ts cl))
              else
-             (`ANY,mk_app_fun2 f_s1n cl ll ((string_of_ts cl) ^ " " ^ (string_of_ts ll)))
+             (`ANY,Trace.mk_app_fun2 f_s1n cl ll ((string_of_ts cl) ^ " " ^ (string_of_ts ll)))
 
          | _ -> assert false
          
       let choose_jump_down tree d =
        choose_jump d
-         (mk_fun (fun _ -> Tree.nil) "Tree.mk_nil")
-         (mk_fun (Tree.tagged_child tree) "Tree.tagged_child") 
-         (mk_fun (Tree.select_child tree) "Tree.select_child")
-         (mk_fun (Tree.tagged_descendant tree) "Tree.tagged_desc")
-         (mk_fun (Tree.select_descendant tree) "Tree.select_desc") 
-         (mk_fun (fun _ _ -> Tree.first_child tree) "[FIRSTCHILD]Tree.select_child_desc")
-         (mk_fun (Tree.first_element tree) "Tree.first_element")
-         (mk_fun (Tree.first_child tree) "Tree.first_child") 
+         (Trace.mk_fun (fun _ -> Tree.nil) "Tree.mk_nil")
+         (Trace.mk_fun (Tree.tagged_child tree) "Tree.tagged_child") 
+         (Trace.mk_fun (Tree.select_child tree) "Tree.select_child")
+         (Trace.mk_fun (Tree.tagged_descendant tree) "Tree.tagged_desc")
+         (Trace.mk_fun (Tree.select_descendant tree) "Tree.select_desc") 
+         (Trace.mk_fun (fun _ _ -> Tree.first_child tree) "[FIRSTCHILD]Tree.select_child_desc")
+         (Trace.mk_fun (Tree.first_element tree) "Tree.first_element")
+         (Trace.mk_fun (Tree.first_child tree) "Tree.first_child") 
 
       let choose_jump_next tree d = 
        choose_jump d
-         (mk_fun (fun _ _ -> Tree.nil) "Tree.mk_nil2")
-         (mk_fun (Tree.tagged_following_sibling_below tree) "Tree.tagged_sibling_ctx")
-         (mk_fun (Tree.select_following_sibling_below tree) "Tree.select_sibling_ctx")
-         (mk_fun (Tree.tagged_following_below tree) "Tree.tagged_foll_ctx")
-         (mk_fun (Tree.select_following_below tree) "Tree.select_foll_ctx")
-         (mk_fun (fun _ _ -> Tree.next_sibling_below tree) "[NEXTSIBLING]Tree.select_sibling_foll_ctx")
-         (mk_fun (Tree.next_element_below tree) "Tree.next_element_ctx")         
-         (mk_fun (Tree.next_sibling_below tree) "Tree.node_sibling_ctx")         
+         (Trace.mk_fun (fun _ _ -> Tree.nil) "Tree.mk_nil2")
+         (Trace.mk_fun (Tree.tagged_following_sibling_below tree) "Tree.tagged_sibling_ctx")
+         (Trace.mk_fun (Tree.select_following_sibling_below tree) "Tree.select_sibling_ctx")
+         (Trace.mk_fun (Tree.tagged_following_below tree) "Tree.tagged_foll_ctx")
+         (Trace.mk_fun (Tree.select_following_below tree) "Tree.select_foll_ctx")
+         (Trace.mk_fun (fun _ _ -> Tree.next_sibling_below tree) "[NEXTSIBLING]Tree.select_sibling_foll_ctx")
+         (Trace.mk_fun (Tree.next_element_below tree) "Tree.next_element_ctx")   
+         (Trace.mk_fun (Tree.next_sibling_below tree) "Tree.node_sibling_ctx")   
                          
          
 
@@ -1173,36 +1191,116 @@ END
 
       module Code3Cache = 
       struct
-       let get = Array.unsafe_get
+       let get = Array.get             
        let set = Array.set
+       let realloc a new_size default =
+         let old_size = Array.length a in
+         if old_size == new_size then a
+         else if new_size == 0 then [||]
+         else let na = Array.create new_size default in
+         Array.blit a 0 na 0 old_size;na
 
        type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> StateSet.t ->  Tag.t -> StateSet.t*RS.t
-       type t = fun_tree array array
-
-       let dummy = fun _ _ _ _ -> failwith "Uninitializd Code3Cache"
-       let default_line = Array.create 1024 dummy (* 256 = max_tag *)
-       let create n = Array.create n default_line 
-       let init f = 
-         for i = 0 to (Array.length default_line) - 1
-         do
-           default_line.(i) <- f
-         done
+       and t = { mutable table : fun_tree array array;
+                 mutable default_elm : fun_tree;
+                 mutable default_line : fun_tree array;
+                  (* statistics *)
+                 mutable access : int;
+                 mutable miss : int;
+                }
+
+
+       let create () = 
+         { table = [||]; 
+           default_elm = (fun _ _ _ _ -> failwith "Uninitialized Code3Cache.t structure\n");
+           default_line = [||];
+           access = 0;
+           miss = 0 }
+
+       let init h f =
+         let default_line = Array.create SMALL_A_SIZE f in
+         begin
+           h.table <- Array.create SMALL_A_SIZE default_line;
+           h.default_elm <- f;
+           h.default_line <- default_line;
+           h.access <- 0;
+           h.miss <- 0
+         end
            
+       let next_power_of_2 n = 
+         let rec loop i acc = 
+           if acc == 0 then i
+           else loop (i+1) (acc lsr 1)
+         in
+         1 lsl (loop 0 n)
+       
        let get_fun h slist tag =
-         get (get h (Uid.to_int slist.StateSet.Node.id)) tag
+         let _ = h.access <- h.access + 1 in
+         let idx = Uid.to_int slist.StateSet.Node.id in
+         let line = 
+           if idx >= Array.length h.table then 
+           let new_tab = realloc h.table (next_power_of_2 idx) h.default_line in
+           let _ =  h.miss <- h.miss + 1; h.table <- new_tab in h.default_line
+           else Array.unsafe_get h.table idx
+         in
+         if tag >= Array.length line then
+         let new_line = realloc line (next_power_of_2 tag) h.default_elm in
+         let _ = h.miss <- h.miss + 1; Array.unsafe_set h.table idx new_line in h.default_elm
+         else Array.unsafe_get line tag
 
        let set_fun (h : t) slist tag (data : fun_tree) =
-         let tab = get h (Uid.to_int slist.StateSet.Node.id) in
-         let line = if tab == default_line then
-           let x = Array.copy tab in
-           (set h (Uid.to_int slist.StateSet.Node.id) x;x)
-         else tab
+         let idx = Uid.to_int slist.StateSet.Node.id in
+         let line = 
+           if idx >= Array.length h.table then 
+           let new_tab = realloc h.table (next_power_of_2 idx) h.default_line in
+           let _ =  h.table <- new_tab in h.default_line
+           else Array.unsafe_get h.table idx
          in
-         set line tag data       
+         let line = if line == h.default_line then 
+         let l = Array.copy line in Array.unsafe_set h.table idx l;l
+         else line in
+         let line = if tag >= Array.length line then
+         let new_line = realloc line (next_power_of_2 tag) h.default_elm in
+         let _ = Array.unsafe_set h.table idx new_line in new_line
+         else line
+         in
+         Array.unsafe_set line tag data
+
+
+       let dump h = Array.iteri 
+         (fun id line -> if line != h.default_line then 
+          begin
+            StateSet.print Format.err_formatter (StateSet.with_id (Uid.of_int id));
+            Format.fprintf Format.err_formatter " -> ";
+            Array.iteri (fun tag clos ->
+                           if clos != h.default_elm then
+                           Format.fprintf Format.err_formatter " (%s,%s) "
+                             (Tag.to_string tag) (Trace.get_funname clos)) line;
+            Format.fprintf Format.err_formatter "\n%!"
+          end
+         ) h.table;
+         Format.fprintf Format.err_formatter "Cache hits: %i, Cache misses: %i, ratio = %f\n%!"
+           h.access h.miss ((float_of_int h.miss)/. (float_of_int h.access));
+         Format.fprintf Format.err_formatter "Size: %i kb\n%!"
+           (((2+(Array.length h.default_line)+
+                (Array.fold_left (fun acc l ->acc + (if l == h.default_line then 0 else Array.length l))
+                (Array.length h.table) h.table)) * Sys.word_size) / 1024)
 
       end
 
+      module StaticEnv =
+      struct
 
+       type t = { stack : Obj.t array; 
+                  mutable top : int; }
+
+       let create () = { stack = Array.create BIG_A_SIZE (Obj.repr 0); top = 0 }
+       let add t e = 
+         let _ = if t.top >= Array.length t.stack then failwith "Static Env overflow" in
+         let i = t.top in Array.unsafe_set t.stack i e; t.top <- i + 1; i
+
+       let get t i :'a = Obj.magic (Array.unsafe_get t.stack i)
+      end
          
       module Fold3Res = struct
        let get = Array.unsafe_get
@@ -1242,6 +1340,8 @@ END
 
       let top_down1 a tree t slist ctx td_trans h_fold2  =     
        (* evaluation starts from the right so we put sl1,res1 at the end *)
+       let env = StaticEnv.create () in
+       let slist_reg = ref StateSet.empty in
        let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) =   
          let data = Fold3Res.find h_fold2 tag fll sl1 sl2  in
          if Fold3Res.is_valid data then
@@ -1254,16 +1354,18 @@ END
           (r, if b then RS.merge conf t res1 res2 else RS.empty))
         
        in
-       let rec loop t ctx slist _  =
+       let loop t ctx slist _ =
          if t == Tree.nil then empty_res else
          let tag = Tree.tag tree t in
          (Code3Cache.get_fun td_trans slist tag) t ctx slist tag
 
-       and loop_tag t ctx slist tag  =
+       in
+       let loop_tag t ctx slist tag =
          if t == Tree.nil then empty_res else 
          (Code3Cache.get_fun td_trans slist tag) t ctx slist tag
          
-       and mk_trans t ctx slist tag = 
+       in
+       let mk_trans t ctx slist tag = 
          let fl_list,llist,rlist,ca,da,sa,fa = 
            StateSet.fold
              (fun q acc ->                         
@@ -1302,15 +1404,15 @@ END
           let cont =
             match f_kind,n_kind with
               | `NIL,`NIL -> 
-                 fun t _ _ tag   -> eval_fold2_slist fl_list t tag empty_res empty_res
+                 fun t _ _ tag -> eval_fold2_slist fl_list t tag empty_res empty_res
                
              |  _,`NIL -> (
                    match f_kind with
                      |`TAG(tag1) -> 
-                       (fun t _ _ tag  -> eval_fold2_slist fl_list t tag empty_res
+                       (fun t _ _ tag -> eval_fold2_slist fl_list t tag empty_res
                          (loop_tag (first t) t llist tag1))
                     | _ ->
-                        fun t _ _ tag  -> eval_fold2_slist fl_list t tag empty_res
+                        fun t _ _ tag -> eval_fold2_slist fl_list t tag empty_res
                           (loop (first t) t llist tag)
                 )
               | `NIL,_ -> (
@@ -1356,18 +1458,29 @@ END
 
              
 
+         in
+         let _ = Trace.register_funname cont 
+           (Printf.sprintf "{first=%s, next=%s}" (Trace.get_funname first)  (Trace.get_funname next))
          in
          Code3Cache.set_fun td_trans slist tag cont; 
-         cont t ctx slist tag 
-       in 
-       let _ = Code3Cache.init mk_trans in
+         cont 
+       in
+       let cache_take_trans t ctx slist tag = 
+         let cont = mk_trans t ctx slist tag in
+         cont t ctx slist tag
+       in
+       Code3Cache.init td_trans (cache_take_trans);
        loop t ctx slist Tag.dummy
-
-
+         
+      
       let run_top_down1 a tree =
-       let _,res = top_down1 a tree Tree.root a.init Tree.root (Code3Cache.create BIG_A_SIZE) (Fold3Res.create BIG_A_SIZE)
+       let code_cache = Code3Cache.create ()  in
+       let fold_cache = Fold3Res.create BIG_A_SIZE in
+       let _,res = top_down1 a tree Tree.root a.init Tree.root code_cache fold_cache
        in 
-         res
+       (*Code3Cache.dump code_cache; *)
+       res
+
 
        module Configuration =
        struct

diff --git a/hcons.ml b/hcons.ml
index 637a60d..7bc8823 100644 (file)
--- a/hcons.ml
+++ b/hcons.ml
@@ -52,6 +52,7 @@ struct
       WH.merge pool cell
 
   exception Found of t
+
   let with_id id = 
     try
       WH.iter (fun r -> if r.id == id then raise (Found r))  pool;      

diff --git a/main.ml b/main.ml
index 1e145d1..76f8089 100644 (file)
--- a/main.ml
+++ b/main.ml
@@ -11,7 +11,7 @@ let () = init_timer();;
 
 let default_gc = Gc.get()
 let tuned_gc = { Gc.get() with
-                  Gc.minor_heap_size = 1024*1024; 
+                  Gc.minor_heap_size = 4*1024*1024;
                   Gc.major_heap_increment = 1024*1024;
                   Gc.max_overhead = 1000000;
                  }

diff --git a/results.c b/results.c
index 82013cb..4e7b4ec 100644 (file)
--- a/results.c
+++ b/results.c
@@ -45,15 +45,13 @@ void freeResults (results R)
 static int conv (int p, int n, int lgn)\r
 \r
   { int t = n+1-(1<<lgn);\r
-    if (p < t) return p;\r
-    return (p<<1)-t;\r
+    return (p < t) ? p : (p<<1)-t;\r
   }\r
 \r
 static int unconv (int p, int n, int lgn)\r
 \r
   { int t = n+1-(1<<lgn);\r
-    if (p < t) return p;\r
-    return (p+t)>>1;\r
+    return (p < t) ? p : (p+t)>>1;\r
   }\r
 \r
 int readResult (results R, int p) // returns 0 or 1\r
@@ -205,8 +203,7 @@ int nextResult (results R, int p) // returns pos of next(p) or -1 if none
   { int answ;\r
     if (((p+1)<<1) > R.n) return -1; // next(last), p+1 out of bounds\r
     answ = nextLarger(R.tree,R.n,conv(p+1,R.n,R.lgn),0,R.lgn);\r
-    if (answ == -1) return -1;\r
-    return unconv(answ,R.n,R.lgn);\r
+    return (answ == -1) ? -1 : unconv(answ,R.n,R.lgn);\r
   }\r
 \r
 // Naively implemented by kim\r