From 92fa1dfd894ed2903541d665bd40919ae154f285 Mon Sep 17 00:00:00 2001 From: kim Date: Wed, 28 Apr 2010 06:45:56 +0000 Subject: [PATCH] Exception less mainloop in ata.ml git-svn-id: svn+ssh://idea.nguyen.vg/svn/sxsi/trunk/xpathcomp@806 3cdefd35-fc62-479d-8e8d-bae585ffb9ca --- Makefile | 6 +- ata.ml | 435 +++++++++++++++++++++--------------------------------- hcons.ml | 23 ++- hcons.mli | 6 + hlist.ml | 5 + hlist.mli | 2 + main.ml | 2 - ptset.ml | 6 +- ptset.mli | 2 + tag.ml | 1 + tag.mli | 2 +- tree.ml | 2 +- uid.ml | 8 +- uid.mli | 3 +- 14 files changed, 217 insertions(+), 286 deletions(-) diff --git a/Makefile b/Makefile index 7079f57..2dc0dfa 100644 --- a/Makefile +++ b/Makefile @@ -40,8 +40,8 @@ SXSIINCLUDES = \ CXXINCLUDES= $(CAMLINCLUDES) $(LIBXMLINCLUDES) $(SXSIINCLUDES) -CXXFLAGS = -O3 -Wall $(INCLUDEDIRS) -fPIC -std=c++0x -static -CCFLAGS = -O3 -Wall -fPIC -static +CXXFLAGS = -O3 -Wall $(INCLUDEDIRS) -std=c++0x -static +CCFLAGS = -O3 -Wall -static ifeq ($(VERBOSE),true) HIDE= @@ -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 -unsafe +OPT_FLAGS = $(DEBUG_FLAGS) $(PROFILE_FLAGS) -nodynlink OCAMLOPT = ocamlopt -cc "$(CXX)" $(OPT_FLAGS) -ccopt -O3 -ccopt -std=c++0x -noassert -inline $(INLINE) diff --git a/ata.ml b/ata.ml index f2b9e72..0b768f5 100644 --- a/ata.ml +++ b/ata.ml @@ -13,9 +13,9 @@ sig end = struct type t = int - let make = - let id = ref (-1) in - fun () -> incr id;!id + let make = let id = ref ~-1 in + fun () -> incr id; !id + let compare = (-) let equal = (==) external hash : t -> int = "%identity" @@ -454,12 +454,12 @@ let tags_of_state a q = else 0 let merge conf t res1 res2 = match conf with - NO -> 0 - | MARK -> 1 - | MARK1 -> res1+1 + NO -> 0 | ONLY1 -> res1 | ONLY2 -> res2 | ONLY12 -> res1+res2 + | MARK -> 1 + | MARK1 -> res1+1 | MARK2 -> res2+1 | MARK12 -> res1+res2+1 @@ -665,8 +665,22 @@ let tags_of_state a q = module Run (RS : ResultSet) = struct - module SList = Hlist.Make (StateSet) - + module SList = struct + include Hlist.Make (StateSet) + let print ppf l = + Format.fprintf ppf "[ "; + begin + match l.Node.node with + | Nil -> () + | Cons(s,ll) -> + StateSet.print ppf s; + iter (fun s -> Format.fprintf ppf "; "; + StateSet.print ppf s) ll + end; + Format.fprintf ppf "]%!" + + + end IFDEF DEBUG @@ -678,8 +692,10 @@ 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 *) let string_of_ts tags = (Ptset.Int.fold (fun t a -> a ^ " " ^ (Tag.to_string t) ) tags "{")^ " }" @@ -822,101 +838,48 @@ END (mk_fun (Tree.next_sibling_below tree) "Tree.node_sibling_ctx") - module SListTable = Hashtbl.Make(struct type t = SList.t - let equal = (==) - let hash t = Uid.to_int t.SList.Node.id - end) - - - module TransCache = - struct - type cell = { key : int; - obj : Obj.t } - type 'a t = cell array - let dummy = { key = 0; obj = Obj.repr () } - let create n = Array.create 25000 dummy - let hash a b = HASHINT2(Obj.magic a, Uid.to_int b.SList.Node.id) - - let find_slot t key = - let rec loop i = - if (t.(i) != dummy) && (t.(i).key != key) - then loop ((i+1 mod 25000)) - else i - in loop (key mod 25000) - ;; - - let find t k1 k2 = - let i = find_slot t (hash k1 k2) in - if t.(i) == dummy then raise Not_found - else Obj.magic (t.(i).obj) - - let add t k1 k2 v = - let key = hash k1 k2 in - let i = find_slot t key in - t.(i)<- { key = key; obj = (Obj.repr v) } - - end - - module TransCache2 = - struct - type 'a t = Obj.t array SListTable.t - let create n = SListTable.create n - let dummy = Obj.repr (fun _ -> assert false) - let find (h :'a t) tag slist : 'a = - let tab = - try - SListTable.find h slist - with - Not_found -> - SListTable.add h slist (Array.create 10000 dummy); - raise Not_found - in - let res = tab.(tag) in - if res == dummy then raise Not_found else (Obj.magic res) - - let add (h : 'a t) tag slist (data : 'a) = - let tab = - try - SListTable.find h slist - with - Not_found -> - let arr = Array.create 10000 dummy in - SListTable.add h slist arr; - arr - in - tab.(tag) <- (Obj.repr data) - - - end - + 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 -> SList.t*RS.t array + type fun_tree = [`Tree] Tree.node -> [`Tree] Tree.node -> Tag.t -> SList.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 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 raise Not_found + if tab == dummy_cell then !default else - let res = get tab tag in - if res == dummy then raise Not_found else res + get tab tag let add (h : t) tag slist (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 100000 dummy in + let x = Array.create 10000 !default 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 end - let td_trans = TransCache.create 100000 (* should be number of tags *number of states^2 + let td_trans = TransCache.create 10000 (* should be number of tags *number of states^2 in the document *) let empty_size n = @@ -924,11 +887,7 @@ END | n -> loop (SList.cons StateSet.empty acc) (n-1) in loop SList.nil n - module FllTable = Hashtbl.Make (struct type t = Formlistlist.t - let equal = (==) - let hash t = Uid.to_int t.Formlistlist.Node.id - end) - + module Fold2Res = struct external get : 'a array -> int ->'a = "%array_unsafe_get" external set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" @@ -962,7 +921,7 @@ END let x = get h tag in if x == dummy then begin - let y = Array.make 100000 dummy in + let y = Array.make 10000 dummy in set h tag y;y end else x @@ -971,7 +930,7 @@ END let x = get af (Uid.to_int fl.Formlistlist.Node.id) in if x == dummy then begin - let y = Array.make 100000 dummy in + let y = Array.make 10000 dummy in set af (Uid.to_int fl.Formlistlist.Node.id) y;y end else x @@ -980,7 +939,7 @@ END let x = get as1 (Uid.to_int s1.SList.Node.id) in if x == dummy then begin - let y = Array.make 100000 dummy_val in + let y = Array.make 10000 dummy_val in set as1 (Uid.to_int s1.SList.Node.id) y;y end else x @@ -988,58 +947,8 @@ END set as2 (Uid.to_int s2.SList.Node.id) data end - - - - module Fold2Res2 = struct - include Hashtbl.Make(struct - type t = Tag.t*Formlistlist.t*SList.t*SList.t - let equal (a,b,c,d) (x,y,z,t) = - a == x && b == y && c == z && d == t - let hash (a,b,c,d) = HASHINT4 (a, - Uid.to_int b.Formlistlist.Node.id, - Uid.to_int c.SList.Node.id, - Uid.to_int d.SList.Node.id) - end) - let add h t f s1 s2 d = - add h (t,f,s1,s2) d - let find h t f s1 s2 = - find h (t,f,s1,s2) - end - - module Fold2ResOld = - struct - type cell = { key : int; - obj : Obj.t } - type 'a t = cell array - let dummy = { key = 0; obj = Obj.repr () } - let create n = Array.create 25000 dummy - let hash a b c d = HASHINT4(Obj.magic a, - Uid.to_int b.Formlistlist.Node.id, - Uid.to_int c.SList.Node.id, - Uid.to_int d.SList.Node.id) - - let find_slot t key = - let rec loop i = - if (t.(i) != dummy) && (t.(i).key != key) - then loop ((i+1 mod 25000)) - else i - in loop (key mod 25000) - ;; - - let find t k1 k2 k3 k4 = - let i = find_slot t (hash k1 k2 k3 k4) in - if t.(i) == dummy then raise Not_found - else Obj.magic (t.(i).obj) - - let add t k1 k2 k3 k4 v = - let key = hash k1 k2 k3 k4 in - let i = find_slot t key in - t.(i)<- { key = key; obj = (Obj.repr v) } - - end - + let h_fold2 = Fold2Res.create 10000 let top_down ?(noright=false) a tree t slist ctx slot_size = @@ -1050,8 +959,8 @@ END 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.(i) <- RS.merge btab.(i) t res1.(i) res2.(i); + 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 @@ -1082,119 +991,105 @@ END in let null_result = (pempty,Array.copy rempty) in - let rec loop t slist ctx = - if t == Tree.nil then null_result else get_trans t slist (Tree.tag tree t) ctx - and loop_tag tag t slist ctx = - if t == Tree.nil then null_result else get_trans t slist tag ctx - and loop_no_right t slist ctx = - if t == Tree.nil then null_result else get_trans ~noright:true t slist (Tree.tag tree t) ctx - and get_trans ?(noright=false) t slist tag ctx = - let cont = - try - TransCache.find td_trans tag slist - with - | Not_found -> - let fl_list,llist,rlist,ca,da,sa,fa = - SList.fold - (fun set (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *) - let fl,ll,rr,ca,da,sa,fa = - StateSet.fold - (fun q acc -> - List.fold_left - (fun ((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc) as acc) - (ts,t) -> - if (TagSet.mem tag ts) - then - let _,_,_,f,_ = t.Transition.node in - let (child,desc,below),(sibl,foll,after) = Formula.st f in - (Formlist.cons t fl_acc, - StateSet.union ll_acc below, - StateSet.union rl_acc after, - StateSet.union child c_acc, - StateSet.union desc d_acc, - StateSet.union sibl s_acc, - StateSet.union foll f_acc) - else acc ) acc ( - try Hashtbl.find a.trans q - with - Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!" - q;[] - ) - - ) set (Formlist.nil,StateSet.empty,StateSet.empty,ca,da,sa,fa) - in (Formlistlist.cons fl fll_acc), (SList.cons ll lllacc), (SList.cons rr rllacc),ca,da,sa,fa) - slist (Formlistlist.nil,SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty) - in - (* Logic to chose the first and next function *) - let tags_child,tags_below,tags_siblings,tags_after = Tree.tags tree tag in - let d_f = Algebra.decide a tags_child tags_below (StateSet.union ca da) true in - let d_n = Algebra.decide a tags_siblings tags_after (StateSet.union sa fa) false in - let f_kind,first = choose_jump_down tree d_f - and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil ) - else choose_jump_next tree d_n in - (*let f_kind,first = `ANY, Tree.first_child tree - and n_kind,next = `ANY, Tree.next_sibling_below tree - in *) - let empty_res = null_result in - let cont = - match f_kind,n_kind with - | `NIL,`NIL -> - (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res empty_res) - | _,`NIL -> ( - match f_kind with - (*|`TAG(tag') -> - let default = fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res - (loop_tag tag' (first t) llist t ) - in - let cf = SList.hd llist in - if (slot_size == 1) && StateSet.is_singleton cf - then - let s = StateSet.choose cf in - if (Algebra.is_rec a s fst) && (Algebra.is_rec a s snd) - && (Algebra.is_final_marking a s) - then - RS.mk_quick_tag_loop default llist 1 tree tag' - else default - else default *) - | _ -> - (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res - (loop (first t) llist t )) - ) - | `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 in - eval_fold2_slist fl_list t tag res2 empty_res - in loop - else - (fun t ctx -> eval_fold2_slist fl_list t (Tree.tag tree t) - (loop_tag tag' (next t ctx) rlist ctx ) empty_res) - - | _ -> - (fun t ctx -> eval_fold2_slist fl_list t (Tree.tag tree t) - (loop (next t ctx) rlist ctx ) empty_res) - ) + 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 + + and loop_no_right 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 true + + and mk_trans t ctx tag slist 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 *) + let fl,ll,rr,ca,da,sa,fa = + StateSet.fold + (fun q acc -> + List.fold_left + (fun ((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc) as acc) + (ts,t) -> + if (TagSet.mem tag ts) + then + let _,_,_,f,_ = t.Transition.node in + let (child,desc,below),(sibl,foll,after) = Formula.st f in + (Formlist.cons t fl_acc, + StateSet.union ll_acc below, + StateSet.union rl_acc after, + StateSet.union child c_acc, + StateSet.union desc d_acc, + StateSet.union sibl s_acc, + StateSet.union foll f_acc) + else acc ) acc ( + try Hashtbl.find a.trans q + with + Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!" + q;[] + ) - | `TAG(tag1),`TAG(tag2) -> - (fun t ctx -> - eval_fold2_slist fl_list t (Tree.tag tree t) - (loop_tag tag2 (next t ctx) rlist ctx ) - (loop_tag tag1 (first t) llist t )) + ) set (Formlist.nil,StateSet.empty,StateSet.empty,ca,da,sa,fa) + in (Formlistlist.cons fl fll_acc), (SList.cons ll lllacc), (SList.cons rr rllacc),ca,da,sa,fa) + slist (Formlistlist.nil,SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty) + in + (* Logic to chose the first and next function *) + let tags_child,tags_below,tags_siblings,tags_after = Tree.tags tree tag in + let d_f = Algebra.decide a tags_child tags_below (StateSet.union ca da) true in + let d_n = Algebra.decide a tags_siblings tags_after (StateSet.union sa fa) false in + let f_kind,first = choose_jump_down tree d_f + 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 cont = + match f_kind,n_kind with + | `NIL,`NIL -> + (fun t _ tag _ _ -> eval_fold2_slist fl_list 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 )) + ) + | `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(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(tag'),`ANY -> - (fun t ctx -> - eval_fold2_slist fl_list t (Tree.tag tree t) - (loop (next t ctx) rlist ctx ) - (loop_tag tag' (first t) llist t )) + | `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 -> - eval_fold2_slist fl_list t (Tree.tag tree t) - (loop_tag tag' (next t ctx) rlist ctx ) - (loop (first t) llist t )) + | `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)) | `ANY,`ANY -> (*if SList.equal slist rlist && SList.equal slist llist @@ -1207,28 +1102,27 @@ END eval_fold2_slist fl_list t (Tree.tag tree t) r2 r1 in loop else *) - (fun t ctx -> - eval_fold2_slist fl_list t (Tree.tag tree t) - (loop (next t ctx) rlist ctx ) - (loop (first t) llist t )) + (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 -> - eval_fold2_slist fl_list t (Tree.tag tree t) - (loop (next t ctx) rlist ctx ) - (loop (first t) llist t )) + (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 -> - let a,b = cont t ctx 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) - in cont t ctx - + in *) + (TransCache.add td_trans tag slist cont; cont t ctx tag slist noright) in - (if noright then loop_no_right else loop) t slist ctx + let _ = TransCache.default := mk_trans in + (if noright then loop_no_right else loop) t ctx Tag.document_node slist let run_top_down a tree = let init = SList.cons a.init SList.nil in @@ -1462,8 +1356,9 @@ END end - let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t) - let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t) + let top_down_count a t = let module RI = Run(Integer) in let r = Integer.length (RI.run_top_down a t) + in (*RI.TransCache.dump RI.td_trans; *)r + let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t) let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k) let bottom_up a t k = let module RI = Run(IdSet) in (RI.run_bottom_up a t k) diff --git a/hcons.ml b/hcons.ml index 9226842..637a60d 100644 --- a/hcons.ml +++ b/hcons.ml @@ -8,10 +8,13 @@ module type SA = val hash : t -> int val uid : t -> Uid.t val equal : t -> t -> bool - end + + val with_id : Uid.t -> t + end module type S = sig + type data type t = private { id : Uid.t; key : int; @@ -22,10 +25,13 @@ module type S = val uid : t -> Uid.t val equal : t -> t -> bool + + val with_id : Uid.t -> t end module Make (H : Hashtbl.HashedType) : S with type data = H.t = struct + let uid_make = Uid.make_maker() type data = H.t type t = { id : Uid.t; key : int; @@ -38,10 +44,21 @@ struct type _t = t type t = _t let hash = hash - let equal a b = a==b || H.equal a.node b.node + let equal a b = a == b || H.equal a.node b.node end) let pool = WH.create MED_H_SIZE let make x = - let cell = { id = Uid.make(); key = H.hash x; node = x } in + let cell = { id = uid_make(); key = H.hash x; node = x } in 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; + raise Not_found + with + | Found r -> r + | e -> raise e + ;; + end diff --git a/hcons.mli b/hcons.mli index bc72d33..888531e 100644 --- a/hcons.mli +++ b/hcons.mli @@ -7,6 +7,9 @@ module type SA = val hash : t -> int val uid : t -> Uid.t val equal : t -> t -> bool + + + val with_id : Uid.t -> t end module type S = @@ -20,6 +23,9 @@ module type S = val hash : t -> int val uid : t -> Uid.t val equal : t -> t -> bool + + + val with_id : Uid.t -> t end module Make (H : Hashtbl.HashedType) : S with type data = H.t diff --git a/hlist.ml b/hlist.ml index e3ad907..0e50d61 100644 --- a/hlist.ml +++ b/hlist.ml @@ -27,6 +27,8 @@ module type S = sig val rev : t -> t val rev_map : (elt -> elt) -> t -> t val length : t -> int + + val with_id : Uid.t -> t end module Make ( H : Hcons.SA ) : S with type elt = H.t = @@ -82,4 +84,7 @@ struct let rev l = fold cons l nil let rev_map f l = fold (fun x acc -> cons (f x) acc) l nil let length l = fold (fun _ c -> c+1) l 0 + + + let with_id = Node.with_id end diff --git a/hlist.mli b/hlist.mli index 1ae44cf..9f8dfc3 100644 --- a/hlist.mli +++ b/hlist.mli @@ -26,6 +26,8 @@ module type S = sig val rev : t -> t val rev_map : (elt -> elt) -> t -> t val length : t -> int + + val with_id : Uid.t -> t end module Make (H : Hcons.SA) : S with type elt = H.t diff --git a/main.ml b/main.ml index e884225..0573e4a 100644 --- a/main.ml +++ b/main.ml @@ -264,5 +264,3 @@ in - -let () = Printf.printf "Hello World!\n" diff --git a/ptset.ml b/ptset.ml index 68f7e2e..87e7506 100644 --- a/ptset.ml +++ b/ptset.ml @@ -19,6 +19,8 @@ sig val from_list : elt list -> t val make : data -> t val node : t -> data + + val with_id : Uid.t -> t end module Make ( H : Hcons.SA ) : S with type elt = H.t = @@ -374,7 +376,7 @@ let rec uncons n = match HNode.node n with let from_list l = List.fold_left (fun acc e -> add e acc) empty l - +let with_id = HNode.with_id end module Int : sig @@ -390,7 +392,7 @@ struct external equal : t -> t -> bool = "%eq" external make : t -> int = "%identity" external node : t -> int = "%identity" - + external with_id : Uid.t -> t = "%identity" end ) let print ppf s = diff --git a/ptset.mli b/ptset.mli index fc95d4e..477acc3 100644 --- a/ptset.mli +++ b/ptset.mli @@ -68,6 +68,8 @@ val uncons : t -> elt * t val from_list : elt list -> t val make : data -> t val node : t -> data + +val with_id : Uid.t -> t end diff --git a/tag.ml b/tag.ml index 139ff91..c692e98 100644 --- a/tag.ml +++ b/tag.ml @@ -16,6 +16,7 @@ external register_tag : pool -> string -> t = "caml_xml_tree_register_tag" external tag_name : pool -> t -> string = "caml_xml_tree_get_tag_name" let nullt = null_tag () +let dummy = nullt (* Defined in XMLTree.cpp *) let document_node = 0 let attribute = 1 diff --git a/tag.mli b/tag.mli index 1fcd5b1..75cd362 100644 --- a/tag.mli +++ b/tag.mli @@ -17,7 +17,7 @@ val to_string : t -> string val compare : t -> t -> int val equal : t -> t -> bool val nullt : t - +val dummy : t val dump : Format.formatter -> t -> unit val check : t -> unit (* Check internal invariants *) diff --git a/tree.ml b/tree.ml index 0a1bdda..8e5dbc7 100644 --- a/tree.ml +++ b/tree.ml @@ -176,7 +176,7 @@ let text_size t = text_size t.doc module MemUnion = Hashtbl.Make (struct type t = Ptset.Int.t*Ptset.Int.t - let equal (x,y) (z,t) = x == z || y == t + let equal (x,y) (z,t) = x == z && y == t let equal a b = equal a b || equal b a let hash (x,y) = (* commutative hash *) let x = Uid.to_int (Ptset.Int.uid x) diff --git a/uid.ml b/uid.ml index bb0fb18..25b9e15 100644 --- a/uid.ml +++ b/uid.ml @@ -1,8 +1,10 @@ type t = int -let _id = ref ~-1 - -let make () = incr _id; !_id +let make_maker () = + let _id = ref ~-1 in + fun () -> incr _id;!_id external to_int : t -> int = "%identity" + +external of_int : int -> t= "%identity" diff --git a/uid.mli b/uid.mli index 235869a..d8dcd88 100644 --- a/uid.mli +++ b/uid.mli @@ -1,3 +1,4 @@ type t = private int -val make : unit -> t +val make_maker : unit -> (unit -> t) external to_int : t -> int = "%identity" +external of_int : int -> t = "%identity" -- 2.17.1