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
  12     val with_id : Uid.t -> t
  13  end
  14
  15 module type S =
  16   sig
  17
  18     type data
  19     type t = private { id : Uid.t;
  20                        key : int;
  21                        node : data }
  22     val make : data -> t
  23     val node : t -> data
  24     val hash : t -> int
  25     val uid : t -> Uid.t
  26     val equal : t -> t -> bool
  27
  28
  29     val with_id : Uid.t -> t
  30   end
  31
  32 module Make (H : Hashtbl.HashedType) : S with type data = H.t =
  33 struct
  34   let uid_make = Uid.make_maker()
  35   type data = H.t
  36   type t = { id : Uid.t;
  37              key : int;
  38              node : data }
  39   let node t = t.node
  40   let uid t = t.id
  41   let hash t = t.key
  42   let equal t1 t2 = t1 == t2
  43   module WH = Weak.Make( struct
  44                            type _t = t
  45                            type t = _t
  46                            let hash = hash
  47                            let equal a b = a == b || H.equal a.node b.node
  48                          end)
  49   let pool = WH.create MED_H_SIZE
  50   let make x =
  51     let cell = { id = uid_make(); key = H.hash x; node = x } in
  52       WH.merge pool cell
  53
  54   exception Found of t
  55   let with_id id =
  56     try
  57       WH.iter (fun r -> if r.id == id then raise (Found r))  pool;
  58       raise Not_found
  59     with
  60       | Found r -> r
  61       | e -> raise e
  62   ;;
  63
  64 end