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 first_free_id () =
  51     let mx = Uid.to_int (uid_current()) + 1 in
  52     let a = Array.create mx Uid.dummy in
  53       WH.iter (fun cell -> a.(Uid.to_int cell.id) <- (Uid.of_int 0)) pool;
  54       try
  55         for i = 0 to mx - 1 do
  56           if a.(i) == Uid.dummy then raise (Found (Uid.of_int i));
  57         done;
  58         uid_make()
  59       with
  60           Found i -> i
  61
  62
  63   let make x =
  64     let cell = { id = Uid.dummy; key = H.hash x; node = x } in
  65       try
  66         WH.find pool cell
  67       with
  68         | Not_found ->
  69             let cell = { id = uid_make(); key = H.hash x; node = x } in
  70               WH.add pool cell;cell
  71
  72   exception Found of t
  73
  74   let stats () =
  75     Printf.eprintf "Hconsing statistics";
  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     List.iter (fun id -> Printf.eprintf "%i\n" id) l
  79 end