Add hooks to re-initialize hconsed modules.

[SXSI/xpathcomp.git] / src / hcons.ml

diff --git a/src/hcons.ml b/src/hcons.ml
index 5a7ad14..daa62a0 100644 (file)
--- a/src/hcons.ml
+++ b/src/hcons.ml
@@ -1,30 +1,32 @@
 INCLUDE "utils.ml"
 module type SA =
-  sig
-    type data
-    type t
-    val make : data -> t
-    val node : t -> data
-    val hash : t -> int
-    val uid : t -> Uid.t
-    val equal : t -> t -> bool
-    val stats : unit -> unit
- end
+sig
+  type data
+  type t
+  val make : data -> t
+  val node : t -> data
+  val hash : t -> int
+  val uid : t -> Uid.t
+  val equal : t -> t -> bool
+  val stats : unit -> unit
+  val init : unit -> unit
+end
 
 module type S =
-  sig
+sig
 
-    type data
-    type t = private { id : Uid.t;
-                      key : int;
-                      node : data }
-    val make : data -> t
-    val node : t -> data
-    val hash : t -> int
-    val uid : t -> Uid.t
-    val equal : t -> t -> bool
-    val stats : unit -> unit
-  end
+  type data
+  type t = private { id : Uid.t;
+                    key : int;
+                    node : data }
+  val make : data -> t
+  val node : t -> data
+  val hash : t -> int
+  val uid : t -> Uid.t
+  val equal : t -> t -> bool
+  val stats : unit -> unit
+  val init : unit -> unit
+end
 
 module Make (H : Hashtbl.HashedType) : S with type data = H.t =
 struct
@@ -38,30 +40,42 @@ struct
   let hash t = t.key
   let equal t1 t2 = t1 == t2
   module WH = Weak.Make( struct
-                          type _t = t
-                          type t = _t
-                          let hash = hash
-                          let equal a b = a == b || H.equal a.node b.node
-                        end)
+    type _t = t
+    type t = _t
+    let hash = hash
+    let equal a b = a == b || H.equal a.node b.node
+  end)
   let pool = WH.create MED_H_SIZE
 
   exception Found of Uid.t
+  let total_count = ref 0
+  let miss_count = ref 0
+  let init () =
+    total_count := 0;
+    miss_count := 0
 
   let make x =
+    incr total_count;
     let cell = { id = Uid.dummy; key = H.hash x; node = x } in
-      try
-       WH.find pool cell
-      with
-       | Not_found ->
-           let cell = { cell with id = uid_make(); } in
-             WH.add pool cell;cell
+    try
+      WH.find pool cell
+    with
+    | Not_found ->
+      let cell = { cell with id = uid_make(); } in
+      incr miss_count;
+      WH.add pool cell;
+      cell
 
   exception Found of t
 
   let stats () =
-    let l = WH.fold (fun cell acc -> (Uid.to_int cell.id)::acc) pool [] in
+    Logger.print Format.err_formatter "Hconsing statistics: %i/%i = %f@\n"
+      !miss_count
+      !total_count
+      ((float_of_int !miss_count) /. (float_of_int !total_count))
+(*    let l = WH.fold (fun cell acc -> (Uid.to_int cell.id)::acc) pool [] in
     let l = List.sort compare l in
     Logger.print Format.err_formatter "Hconsing statistics:@\n%a"
-    (fun ppf l ->
-      Pretty.pp_print_list ~sep:Format.pp_force_newline Format.pp_print_int ppf l) l
+      (fun ppf l ->
+        Pretty.pp_print_list ~sep:Format.pp_force_newline Format.pp_print_int ppf l) l *)
 end