Source file hc.ml

type +'a hash_consed =
  { node : 'a
  ; tag : int
  }

let get_initial_cache_size, set_initial_cache_size, reset_initial_cache_size =
  let default = 512 in
  let initial_cache_size = ref default in
  ( (fun () -> !initial_cache_size)
  , (fun size -> initial_cache_size := size)
  , fun () -> initial_cache_size := default )

module type Cache = sig
  type key

  type !'a t

  val create : int -> 'a t

  val clear : 'a t -> unit

  val add : 'a t -> key -> 'a -> unit

  val find : 'a t -> key -> 'a

  val length : 'a t -> int

  val stats : 'a t -> Hashtbl.statistics
end

module type S = sig
  type key

  val clear : unit -> unit

  val hashcons : key -> key hash_consed

  val stats : unit -> Hashtbl.statistics

  val length : unit -> int
end

module Mk (Cache : Cache) : S with type key = Cache.key = struct
  type key = Cache.key

  let tbl = Cache.create (get_initial_cache_size ())

  let count = ref ~-1

  let gen_tag () =
    incr count;
    !count

  let hashcons node =
    match Cache.find tbl node with
    | exception Not_found ->
      let tag = gen_tag () in
      let v = { tag; node } in
      Cache.add tbl node v;
      v
    | v -> v

  let clear () = Cache.clear tbl

  let stats () = Cache.stats tbl

  let length () = Cache.length tbl
end

module Make (H : Hashtbl.HashedType) : S with type key = H.t = struct
  include Mk (Ephemeron.K1.Make (H))
end

module MakeStrong (H : Hashtbl.HashedType) : S with type key = H.t = struct
  include Mk (Hashtbl.Make (H))
end

module Fake (H : Hashtbl.HashedType) : S with type key = H.t = struct
  include Mk (struct
    type key = H.t

    type 'a t = Unit

    let create (_size : int) = Unit

    let clear Unit = ()

    let add (Unit : 'a t) (_v : key) (_ : 'a) = ()

    let find Unit (_v : key) = raise_notrace Not_found

    let length Unit = 0

    let stats Unit =
      { Hashtbl.num_bindings = 0
      ; num_buckets = 0
      ; max_bucket_length = 0
      ; bucket_histogram = [||]
      }
  end)
end