src/hcons.ml

   1 INCLUDE "utils.ml"
   2 module type SA =
   3   sig
   4     type data
   5     type t
   6     val make : data -> t
   7     val node : t -> data
   8     val hash : t -> int
   9     val uid : t -> Uid.t
  10     val equal : t -> t -> bool
  11     val stats : unit -> unit
  12  end
  13
  14 module type S =
  15   sig
  16
  17     type data
  18     type t = private { id : Uid.t;
  19                        key : int;
  20                        node : data }
  21     val make : data -> t
  22     val node : t -> data
  23     val hash : t -> int
  24     val uid : t -> Uid.t
  25     val equal : t -> t -> bool
  26     val stats : unit -> unit
  27   end
  28
  29 module Make (H : Hashtbl.HashedType) : S with type data = H.t =
  30 struct
  31   let uid_make,uid_current,uid_set = Uid.make_maker()
  32   type data = H.t
  33   type t = { id : Uid.t;
  34              key : int;
  35              node : data }
  36   let node t = t.node
  37   let uid t = t.id
  38   let hash t = t.key
  39   let equal t1 t2 = t1 == t2
  40   module WH = Weak.Make( struct
  41                            type _t = t
  42                            type t = _t
  43                            let hash = hash
  44                            let equal a b = a == b || H.equal a.node b.node
  45                          end)
  46   let pool = WH.create MED_H_SIZE
  47
  48   exception Found of Uid.t
  49
  50   let make x =
  51     let cell = { id = Uid.dummy; key = H.hash x; node = x } in
  52       try
  53         WH.find pool cell
  54       with
  55         | Not_found ->
  56             let cell = { cell with id = uid_make(); } in
  57               WH.add pool cell;cell
  58
  59   exception Found of t
  60
  61   let stats () =
  62     Printf.eprintf "Hconsing statistics";
  63     let l = WH.fold (fun cell acc -> (Uid.to_int cell.id)::acc) pool [] in
  64     let l = List.sort compare l in
  65     List.iter (fun id -> Printf.eprintf "%i\n" id) l
  66 end