From: kim Date: Wed, 28 Apr 2010 06:46:48 +0000 (+0000) Subject: Major optimization, rewrite to avoid deep recursion if possible. X-Git-Url: http://git.nguyen.vg/gitweb/?a=commitdiff_plain;h=861944c24f8cad360fb9478cb0a15863cb52e803;p=SXSI%2Fxpathcomp.git 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 --- 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 --- 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 --- 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 --- a/results.c +++ b/results.c @@ -45,15 +45,13 @@ void freeResults (results R) static int conv (int p, int n, int lgn) { int t = n+1-(1<>1; + return (p < t) ? p : (p+t)>>1; } int readResult (results R, int p) // returns 0 or 1 @@ -205,8 +203,7 @@ int nextResult (results R, int p) // returns pos of next(p) or -1 if none { int answ; if (((p+1)<<1) > R.n) return -1; // next(last), p+1 out of bounds answ = nextLarger(R.tree,R.n,conv(p+1,R.n,R.lgn),0,R.lgn); - if (answ == -1) return -1; - return unconv(answ,R.n,R.lgn); + return (answ == -1) ? -1 : unconv(answ,R.n,R.lgn); } // Naively implemented by kim