From d046f2b9d8e39b30350399eafe122c30ff61c8c1 Mon Sep 17 00:00:00 2001 From: kim Date: Wed, 28 Apr 2010 06:46:22 +0000 Subject: [PATCH] Fast closure branch git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@808 3cdefd35-fc62-479d-8e8d-bae585ffb9ca --- Makefile | 8 +- ata.ml | 419 ++++++++++++++++++++++++++++--------------------------- main.ml | 4 +- tree.ml | 4 +- 4 files changed, 225 insertions(+), 210 deletions(-) diff --git a/Makefile b/Makefile index 2dc0dfa..88620eb 100644 --- a/Makefile +++ b/Makefile @@ -64,7 +64,7 @@ PROFILE_FLAGS = -p -S SYNT_PROF = -ppopt -DPROFILE endif SYNT_FLAGS = $(SYNT_DEBUG) $(SYNT_PROF) -OPT_FLAGS = $(DEBUG_FLAGS) $(PROFILE_FLAGS) -nodynlink +OPT_FLAGS = $(DEBUG_FLAGS) $(PROFILE_FLAGS) -nodynlink -fno-PIC OCAMLOPT = ocamlopt -cc "$(CXX)" $(OPT_FLAGS) -ccopt -O3 -ccopt -std=c++0x -noassert -inline $(INLINE) @@ -108,9 +108,9 @@ unit_test: libcamlshredder.a $(BASEOBJS) unit_test.cmx @echo [OCAMLOPT] $@ $(HIDE) $(OCAMLFIND) $(OCAMLOPT) -package "$(OCAMLPACKAGES)" $(SYNTAX) -c $< -#ata.cmx: ata.ml -# @echo [OCAMLOPTPROF] $@ -# $(HIDE) $(OCAMLFIND) $(OCAMLOPT) -ccopt -gp -p -package "$(OCAMLPACKAGES)" $(SYNTAX) -c $< +ata.cmx: ata.ml + @echo [OCAMLOPTPROF] $@ + $(HIDE) $(OCAMLFIND) $(OCAMLOPT) -S -package "$(OCAMLPACKAGES)" $(SYNTAX) -c $< .mli.cmi: @echo [OCAMLOPT] $@ diff --git a/ata.ml b/ata.ml index 0b768f5..9197cbc 100644 --- a/ata.ml +++ b/ata.ml @@ -838,48 +838,40 @@ END (mk_fun (Tree.next_sibling_below tree) "Tree.node_sibling_ctx") - - module TransCache = - struct - external get : 'a array -> int ->'a = "%array_unsafe_get" - external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" - type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> Tag.t -> SList.t -> bool -> SList.t*RS.t array + + + module CodeCache = + struct + let get = Array.unsafe_get + let set = Array.set + + type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> SList.t -> Tag.t -> bool -> SList.t*RS.t array type t = fun_tree array array - let dummy_cell = [||] - let create n = Array.create n dummy_cell - let dummy = fun _ _ _ _ _ -> assert false - let default = ref dummy - let find h tag slist = - let tab = get h (Uid.to_int slist.SList.Node.id) in - if tab == dummy_cell then !default - else - get tab tag - let add (h : t) tag slist (data : fun_tree) = + let dummy = fun _ _ _ _ _ -> failwith "Uninitializd CodeCache" + let default_line = Array.create 256 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 + + let get_fun h slist tag = + get (get h (Uid.to_int slist.SList.Node.id)) tag + + let set_fun (h : t) slist tag (data : fun_tree) = let tab = get h (Uid.to_int slist.SList.Node.id) in - let tab = if tab == dummy_cell then - let x = Array.create 10000 !default in + let line = if tab == default_line then + let x = Array.copy tab in (set h (Uid.to_int slist.SList.Node.id) x;x) else tab in - set tab tag data - let dump t = Array.iteri (fun id t' -> - if t' != dummy_cell then - begin - let sl = SList.with_id (Uid.of_int id) in - SList.print Format.err_formatter sl; - Format.fprintf Format.err_formatter " -> [ "; - Array.iteri - (fun i x -> if x != !default then - Format.fprintf Format.err_formatter "(%s,0x%x) " - (Tag.to_string i) (Obj.magic x)) t'; - Format.fprintf Format.err_formatter " ]\n%!" - - end) t + set line tag data + end - - - let td_trans = TransCache.create 10000 (* should be number of tags *number of states^2 + + let td_trans = CodeCache.create 10000 (* should be number of tags *number of states^2 in the document *) let empty_size n = @@ -889,67 +881,40 @@ END module Fold2Res = struct - external get : 'a array -> int ->'a = "%array_unsafe_get" - external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" - external field1 : 'a -> 'b = "%field1" - type 'a t = 'a array array array array - let dummy = [||] - let dummy_val : 'a = - let v = Obj.repr ((),2,()) in - Obj.magic v - - - let create n = Array.create n dummy - let find h tag fl s1 s2 = - let af = get h tag in - if af == dummy then raise Not_found - else - let as1 = get af (Uid.to_int fl.Formlistlist.Node.id) in - if as1 == dummy then raise Not_found - else - let as2 = get as1 (Uid.to_int s1.SList.Node.id) in - if as2 == dummy then raise Not_found - else - let v = get as2 (Uid.to_int s2.SList.Node.id) in - if field1 v == 2 then raise Not_found - else - v + let get = Array.unsafe_get + let set = Array.set + external field1 : Obj.t -> int = "%field1" + type t = Obj.t array array array array + let dummy_val = Obj.repr ((),2,()) + let default_line3 = Array.create 10000 dummy_val + let default_line2 = Array.create 10000 default_line3 + let default_line1 = Array.create 10000 default_line2 + + let create n = Array.create n default_line1 - let add h tag fl s1 s2 data = - let af = - let x = get h tag in - if x == dummy then - begin - let y = Array.make 10000 dummy in - set h tag y;y - end - else x - in - let as1 = - let x = get af (Uid.to_int fl.Formlistlist.Node.id) in - if x == dummy then - begin - let y = Array.make 10000 dummy in - set af (Uid.to_int fl.Formlistlist.Node.id) y;y - end - else x - in - let as2 = - let x = get as1 (Uid.to_int s1.SList.Node.id) in - if x == dummy then - begin - let y = Array.make 10000 dummy_val in - set as1 (Uid.to_int s1.SList.Node.id) y;y - end - else x - in - set as2 (Uid.to_int s2.SList.Node.id) data + let find h tag fl s1 s2 : SList.t*bool*(merge_conf array) = + let l1 = get h tag in + let l2 = get l1 (Uid.to_int fl.Formlistlist.Node.id) in + let l3 = get l2 (Uid.to_int s1.SList.Node.id) in + Obj.magic (get l3 (Uid.to_int s2.SList.Node.id)) + + let is_valid b = (Obj.magic b) != 2 + let get_replace tab idx default = + let e = get tab idx in + if e == default then + let ne = Array.copy e in (set tab idx ne;ne) + else e + + let add h tag fl s1 s2 (data: SList.t*bool*(merge_conf array)) = + let l1 = get_replace h tag default_line1 in + let l2 = get_replace l1 (Uid.to_int fl.Formlistlist.Node.id) default_line2 in + let l3 = get_replace l2 (Uid.to_int s1.SList.Node.id) default_line3 in + set l3 (Uid.to_int s2.SList.Node.id) (Obj.repr data) end - - - let h_fold2 = Fold2Res.create 10000 + + let h_fold2 = Fold2Res.create 256 let top_down ?(noright=false) a tree t slist ctx slot_size = let pempty = empty_size slot_size in @@ -957,52 +922,109 @@ END (* evaluation starts from the right so we put sl1,res1 at the end *) let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) = let res = Array.copy rempty in - try - let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in - if b then for i=0 to slot_size - 1 do - res.(0) <- RS.merge btab.(0) t res1.(0) res2.(0); - done; - r,res - with - Not_found -> - begin - let btab = Array.make slot_size NO in - let rec fold l1 l2 fll i aq ab = - match fll.Formlistlist.Node.node, - l1.SList.Node.node, - l2.SList.Node.node - with - | Formlistlist.Cons(fl,fll), - SList.Cons(s1,ll1), - SList.Cons(s2,ll2) -> - let r',conf = eval_formlist tag s1 s2 fl in - let _ = btab.(i) <- conf - in - fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab) - | _ -> aq,ab - in - let r,b = fold sl1 sl2 fll 0 SList.nil false in - Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab); - if b then for i=0 to slot_size - 1 do - res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i); - done; - r,res; - end + let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in + if Fold2Res.is_valid b then + begin + if b then for i=0 to slot_size - 1 do + res.(0) <- RS.merge btab.(0) t res1.(0) res2.(0); + done; + r,res + end + else + begin + let btab = Array.make slot_size NO in + let rec fold l1 l2 fll i aq ab = + match fll.Formlistlist.Node.node, + l1.SList.Node.node, + l2.SList.Node.node + with + | Formlistlist.Cons(fl,fll), + SList.Cons(s1,ll1), + SList.Cons(s2,ll2) -> + let r',conf = eval_formlist tag s1 s2 fl in + let _ = btab.(i) <- conf + in + fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab) + | _ -> aq,ab + in + let r,b = fold sl1 sl2 fll 0 SList.nil false in + Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab); + if b then for i=0 to slot_size - 1 do + res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i); + done; + r,res; + end in let null_result = (pempty,Array.copy rempty) in - let rec loop t ctx _ slist = - if t == Tree.nil then null_result else - let tag = Tree.tag tree t in (TransCache.find td_trans tag slist) t ctx tag slist false - - and loop_tag t ctx tag slist = - if t == Tree.nil then null_result else (TransCache.find td_trans tag slist) t ctx tag slist false + let empty_res = null_result in - and loop_no_right t ctx _ slist = + let rec loop t ctx slist _ = + if t == Tree.nil then null_result else + let tag = Tree.tag tree t in + (CodeCache.get_fun td_trans slist tag) t ctx slist tag false + (* get_trans t ctx slist tag false + (CodeCache.get_opcode td_trans slist tag) + *) + and loop_tag t ctx slist tag = if t == Tree.nil then null_result else - let tag = Tree.tag tree t in (TransCache.find td_trans tag slist) t ctx tag slist true - - and mk_trans t ctx tag slist noright = + (CodeCache.get_fun td_trans slist tag) t ctx slist tag false + (* get_trans t ctx slist tag false + (CodeCache.get_opcode td_trans slist tag) *) + + and loop_no_right t ctx slist _ = + if t == Tree.nil then null_result else + let tag = Tree.tag tree t in + (CodeCache.get_fun td_trans slist tag) t ctx slist tag true + (* get_trans t ctx slist tag true + (CodeCache.get_opcode td_trans slist tag) *) + (* + and get_trans t ctx slist tag noright opcode = + match opcode with + | OpCode.K0 fll -> + eval_fold2_slist fll t tag empty_res empty_res + + | OpCode.K1 (fll,first,llist,tag1) -> + eval_fold2_slist fll t tag empty_res + (loop_tag (first t) t llist tag1) + + | OpCode.K2 (fll,first,llist) -> + eval_fold2_slist fll t tag empty_res + (loop (first t) t llist) + + | OpCode.K3 (fll,next,rlist,tag2) -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + empty_res + | OpCode.K4 (fll,next,rlist) -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist) + empty_res + + | OpCode.K5 (fll,next,rlist,tag2,first,llist,tag1) -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + (loop_tag (first t) t llist tag1) + + | OpCode.K6 (fll,next,rlist,first,llist,tag1) -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist) + (loop_tag (first t) t llist tag1) + + | OpCode.K7 (fll,next,rlist,tag2,first,llist) -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + (loop (first t) t llist) + + | OpCode.K8 (fll,next,rlist,first,llist) -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist) + (loop (first t) t llist) + + | OpCode.KDefault _ -> + mk_trans t ctx tag slist noright + *) + and mk_trans t ctx slist tag noright = let fl_list,llist,rlist,ca,da,sa,fa = SList.fold (fun set (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *) @@ -1042,87 +1064,80 @@ END and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil ) else choose_jump_next tree d_n in let empty_res = null_result in + let fll = fl_list in let cont = match f_kind,n_kind with - | `NIL,`NIL -> - (fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res empty_res) + | `NIL,`NIL -> (*OpCode.K0(fl_list) *) + fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res empty_res + | _,`NIL -> ( match f_kind with - |`TAG(tag') -> - fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res - (loop_tag (first t) t tag' llist ) - | _ -> - (fun t _ tag _ _ -> eval_fold2_slist fl_list t tag empty_res - (loop (first t) t Tag.dummy llist )) + |`TAG(tag1) -> (*OpCode.K1(fl_list,first,llist,tag1) *) + fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res + (loop_tag (first t) t llist tag1) + | _ -> (* OpCode.K2(fl_list,first,llist) *) + fun t _ _ tag _ -> eval_fold2_slist fll t tag empty_res + (loop (first t) t llist tag) ) | `NIL,_ -> ( match n_kind with - |`TAG(tag') -> - if SList.equal rlist slist && tag == tag' then - let rec loop t ctx _ _ _ = - if t == Tree.nil then empty_res else - let res2 = loop (next t ctx) ctx Tag.dummy slist false in - eval_fold2_slist fl_list t tag res2 empty_res - in loop - else - (fun t ctx tag _ _ -> eval_fold2_slist fl_list t tag - (loop_tag (next t ctx) ctx tag' rlist) empty_res) - - | _ -> - (fun t ctx tag _ _ -> eval_fold2_slist fl_list t tag - (loop (next t ctx) ctx Tag.dummy rlist ) empty_res) + |`TAG(tag2) -> (*OpCode.K3(fl_list,next,rlist,tag2) *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + empty_res + + | _ -> (*OpCode.K4(fl_list,next,rlist) *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist tag) + empty_res + ) - | `TAG(tag1),`TAG(tag2) -> - (fun t ctx tag _ _ -> - eval_fold2_slist fl_list t tag - (loop_tag (next t ctx) ctx tag2 rlist) - (loop_tag (first t) t tag1 llist)) + | `TAG(tag1),`TAG(tag2) -> (*OpCode.K5(fl_list,next,rlist,tag2,first,llist,tag1) *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + (loop_tag (first t) t llist tag1) - | `TAG(tag'),`ANY -> - (fun t ctx tag _ _ -> - eval_fold2_slist fl_list t tag - (loop (next t ctx) ctx Tag.dummy rlist) - (loop_tag (first t) t tag' llist)) - - | `ANY,`TAG(tag') -> - (fun t ctx tag _ _ -> - eval_fold2_slist fl_list t tag - (loop_tag (next t ctx) ctx tag' rlist ) - (loop (first t) t Tag.dummy llist)) + | `TAG(tag1),`ANY -> (* OpCode.K6(fl_list,next,rlist,first,llist,tag1) *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist tag) + (loop_tag (first t) t llist tag1) + + | `ANY,`TAG(tag2) -> (* OpCode.K7(fl_list,next,rlist,tag2,first,llist) *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop_tag (next t ctx) ctx rlist tag2) + (loop (first t) t llist tag) + - | `ANY,`ANY -> - (*if SList.equal slist rlist && SList.equal slist llist - then - let rec loop t ctx = - if t == Tree.nil then empty_res else - let r1 = loop (first t) t - and r2 = loop (next t ctx) ctx - in - eval_fold2_slist fl_list t (Tree.tag tree t) r2 r1 - in loop - else *) - (fun t ctx tag _ _ -> - eval_fold2_slist fl_list t tag - (loop (next t ctx) ctx Tag.dummy rlist ) - (loop (first t) t Tag.dummy llist)) - | _,_ -> - (fun t ctx tag _ _ -> - eval_fold2_slist fl_list t tag - (loop (next t ctx) ctx Tag.dummy rlist) - (loop (first t) t Tag.dummy llist )) - - in - (* let cont = D_IF_( (fun t ctx tag -> - let a,b = cont t ctx tag in - register_trace tree t (slist,a,fl_list,first,next,ctx); - (a,b) - ) ,cont) - in *) - (TransCache.add td_trans tag slist cont; cont t ctx tag slist noright) + | _,_ -> (*OpCode.K8(fl_list,next,rlist,first,llist) *) + (*if SList.equal slist rlist && SList.equal slist llist + then + let rec loop t ctx = + if t == Tree.nil then empty_res else + let r1 = loop (first t) t + and r2 = loop (next t ctx) ctx + in + eval_fold2_slist fl_list t (Tree.tag tree t) r2 r1 + in loop + else *) + fun t ctx _ tag _ -> + eval_fold2_slist fll t tag + (loop (next t ctx) ctx rlist tag) + (loop (first t) t llist tag) + + + + in + CodeCache.set_fun td_trans slist tag cont; + cont t ctx slist tag noright in - let _ = TransCache.default := mk_trans in - (if noright then loop_no_right else loop) t ctx Tag.document_node slist + let _ = CodeCache.init mk_trans in + (if noright then loop_no_right else loop) t ctx slist Tag.dummy let run_top_down a tree = let init = SList.cons a.init SList.nil in diff --git a/main.ml b/main.ml index 0064adc..5a7f120 100644 --- a/main.ml +++ b/main.ml @@ -96,7 +96,7 @@ let main v query_string output = (* let _ = test_text v in *) (* let _ = Tree.stats v in *) let _ = Printf.eprintf "Timing first_child/next_sibling %!" in - let _ = time ~count:5 (Tree.benchmark_fcns) v in (* + let _ = time ~count:0 (Tree.benchmark_fcns) v in (* let _ = Printf.eprintf "Timing last_child/prev_sibling %!" in let _ = time (Tree.benchmark_lcps) v in let _ = Printf.eprintf "Timing jump to a %!" in @@ -165,7 +165,7 @@ let main v query_string output = begin let _ = Gc.full_major();Gc.compact() in let _ = Printf.eprintf "%!" in -(* let _ = Gc.set (disabled_gc) in *) + let _ = Gc.set (disabled_gc) in if !Options.backward && ((snd test_list) != `NOTHING )then if !Options.count_only then let r = time_mem (bottom_up_count auto v )(snd test_list) in diff --git a/tree.ml b/tree.ml index 8e5dbc7..4b7cb54 100644 --- a/tree.ml +++ b/tree.ml @@ -430,7 +430,7 @@ let load ?(sample=64) ?(load_text=true) str = let in_c = Unix.in_channel_of_descr fd in let _ = set_binary_mode_in in_c true in let load_table () = - (let ms = input_line in_c in if ms <> magic_string then failwith "Invalid index file"); + (let ms = input_line in_c in if ms <> magic_string then failwith ("Invalid index file " ^ ms)); (let vs = input_line in_c in if vs <> version_string then failwith "Invalid version file"); let table : (Tag.t,(Ptset.Int.t*Ptset.Int.t*Ptset.Int.t*Ptset.Int.t)) Hashtbl.t = Marshal.from_channel in_c @@ -450,7 +450,7 @@ let load ?(sample=64) ?(load_text=true) str = ntable in let _ = Printf.eprintf "\nLoading tag table : " in - let ntable = time (load_table) () in + let ntable = time ~count:0 load_table () in ignore(Unix.lseek fd (pos_in in_c) Unix.SEEK_SET); let tree = { doc = tree_load fd load_text sample; ttable = ntable;} -- 2.17.1