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   val init : unit -> unit
  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   val stats : unit -> unit
  28   val init : unit -> unit
  29 end
  30
  31 module Make (H : Hashtbl.HashedType) : S with type data = H.t =
  32 struct
  33   let uid_make,uid_current,uid_set = Uid.make_maker()
  34   type data = H.t
  35   type t = { id : Uid.t;
  36              key : int;
  37              node : data }
  38   let node t = t.node
  39   let uid t = t.id
  40   let hash t = t.key
  41   let equal t1 t2 = t1 == t2
  42   module WH = Weak.Make( struct
  43     type _t = t
  44     type t = _t
  45     let hash = hash
  46     let equal a b = a == b || H.equal a.node b.node
  47   end)
  48   let pool = WH.create MED_H_SIZE
  49
  50   exception Found of Uid.t
  51   let total_count = ref 0
  52   let miss_count = ref 0
  53   let init () =
  54     total_count := 0;
  55     miss_count := 0
  56
  57   let make x =
  58     incr total_count;
  59     let cell = { id = Uid.dummy; key = H.hash x; node = x } in
  60     try
  61       WH.find pool cell
  62     with
  63     | Not_found ->
  64       let cell = { cell with id = uid_make(); } in
  65       incr miss_count;
  66       WH.add pool cell;
  67       cell
  68
  69   exception Found of t
  70
  71   let stats () =
  72     Logger.print Format.err_formatter "Hconsing statistics: %i/%i = %f@\n"
  73       !miss_count
  74       !total_count
  75       ((float_of_int !miss_count) /. (float_of_int !total_count))
  76 (*    let l = WH.fold (fun cell acc -> (Uid.to_int cell.id)::acc) pool [] in
  77     let l = List.sort compare l in
  78     Logger.print Format.err_formatter "Hconsing statistics:@\n%a"
  79       (fun ppf l ->
  80         Pretty.pp_print_list ~sep:Format.pp_force_newline Format.pp_print_int ppf l) l *)
  81 end