upool.ml 1.27 KB
Newer Older
1 2 3 4 5 6
type 'a typed_int = int
external int: 'a typed_int -> int = "%identity"

module type S = sig
  type token
  type value
7
  include Custom.T with type t = token typed_int
8 9 10 11 12 13 14 15 16 17 18 19 20 21
  exception Not_unique of value * value

  val dummy: t
  val mk: value -> t
  val get: t -> value

  val extract: unit -> value list
  val intract: value list -> unit
end

module HInt = Hashtbl.Make(struct type t = int
				  let hash x = x
				  let equal x y = x==y end)

22
module Make(X : Custom.T) = struct
23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49
  type token
  type value = X.t
  type t = token typed_int

  exception Not_unique of value * value
  let compare (x:int) y = if (x=y) then 0 else if (x < y) then (-1) else 1
  let hash x = x
  let equal x y = x==y

  let pool = HInt.create 1024
  let dummy = max_int

  let mk v =
    let h = X.hash v in
    if (h == dummy) then raise (Not_unique (v,v));
    (try 
       let v' = HInt.find pool h in 
       if not (X.equal v v') then raise (Not_unique (v,v'));
     with Not_found -> HInt.add pool h v);
    h

  let get h = 
    assert (h != dummy);
    HInt.find pool h

  let extract () = HInt.fold (fun _ v accu -> v::accu) pool []
  let intract = List.iter (fun v -> ignore (mk v))
50 51 52 53 54 55

  let serialize s h = X.serialize s (get h)
  let deserialize s = mk (X.deserialize s)

  let check _ = ()
  let dump ppf _ = ()
56
end