first commit

.gitignore

@@ -0,0 +1,3 @@
+*.merlin
+_build/
+_coverage/

.ocamlformat

@@ -0,0 +1,43 @@
+version=0.27.0
+assignment-operator=end-line
+break-cases=fit
+break-fun-decl=wrap
+break-fun-sig=wrap
+break-infix=wrap
+break-infix-before-func=false
+break-separators=before
+break-sequences=true
+cases-exp-indent=2
+cases-matching-exp-indent=normal
+doc-comments=before
+doc-comments-padding=2
+doc-comments-tag-only=default
+dock-collection-brackets=false
+exp-grouping=preserve
+field-space=loose
+if-then-else=compact
+indicate-multiline-delimiters=space
+indicate-nested-or-patterns=unsafe-no
+infix-precedence=indent
+leading-nested-match-parens=false
+let-and=sparse
+let-binding-spacing=compact
+let-module=compact
+margin=80
+max-indent=2
+module-item-spacing=sparse
+ocaml-version=4.14.0
+ocp-indent-compat=false
+parens-ite=false
+parens-tuple=always
+parse-docstrings=true
+sequence-blank-line=preserve-one
+sequence-style=terminator
+single-case=compact
+space-around-arrays=true
+space-around-lists=true
+space-around-records=true
+space-around-variants=true
+type-decl=sparse
+wrap-comments=false
+wrap-fun-args=true

CHANGES.md

@@ -0,0 +1,25 @@
+## unreleased
+
+## 0.5 - 2025-05-21
+
+- expose thread-safe and thread-unsafe functors
+
+## 0.4 - 2024-06-06
+
+- add some inlining hints
+
+## 0.3 - 2024-01-26
+
+- write doc
+- make `hash_consed` type private
+- write proper interface
+- lower OCaml bound to 4.14
+
+## 0.2 - 2024-01-25
+
+- update for OCaml 5.0
+- add Fake functor
+
+## 0.0.1 - 2019-11-23
+
+- first release

LICENSE.md

@@ -0,0 +1,8 @@
+The ISC License (ISC)
+=====================
+
+Copyright © 2019, pena
+
+Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

README.md

@@ -0,0 +1,12 @@
+# Hc
+
+Hc is an [OCaml] library for [hash consing].
+
+## License
+
+See [LICENSE].
+
+[LICENSE]: ./LICENSE.md
+
+[hash consing]: https://en.wikipedia.org/wiki/Hash_consing
+[OCaml]: https://en.wikipedia.org/wiki/OCaml

dune-project

@@ -0,0 +1,29 @@
+(lang dune 3.0)
+
+(name hc)
+
+(license ISC)
+
+(authors "pena <pena@kumikode.org>")
+
+(maintainers "pena <pena@kumikode.org>")
+
+(source
+ (uri git+https://forge.kumikode.org/kumikode/hc.git))
+
+(bug_reports https://forge.kumikode.org/kumikode/hc/issues)
+
+(homepage https://forge.kumikode.org/kumikode/hc)
+
+(generate_opam_files true)
+
+(explicit_js_mode)
+
+(package
+ (name hc)
+ (synopsis "Hashconsing library")
+ (description
+  "hc is an OCaml library for hashconsing. It provides easy ways to use hashconsing, in a type-safe and modular way and the ability to get forgetful memoïzation.")
+ (depends
+  (ocaml
+   (>= 4.14))))

hc.opam

@@ -0,0 +1,30 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "Hashconsing library"
+description:
+  "hc is an OCaml library for hashconsing. It provides easy ways to use hashconsing, in a type-safe and modular way and the ability to get forgetful memoïzation."
+maintainer: ["pena <pena@kumikode.org>"]
+authors: ["pena <pena@kumikode.org>"]
+license: "ISC"
+homepage: "https://forge.kumikode.org/kumikode/hc"
+bug-reports: "https://forge.kumikode.org/kumikode/hc/issues"
+depends: [
+  "dune" {>= "3.0"}
+  "ocaml" {>= "4.14"}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://forge.kumikode.org/kumikode/hc.git"

src/dune

@@ -0,0 +1,3 @@
+(library
+ (public_name hc)
+ (libraries threads))

src/hc.ml

@@ -0,0 +1,143 @@
+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 tag = ref ~-1
+
+  let hashcons node =
+    try Cache.find tbl node
+    with Not_found ->
+      incr tag;
+      let tag = !tag in
+      let v = { tag; node } in
+      Cache.add tbl node v;
+      v
+
+  let clear () = Cache.clear tbl
+
+  let stats () = Cache.stats tbl
+
+  let length () = Cache.length tbl
+end
+
+module Mk_thread_safe (Cache : Cache) : S with type key = Cache.key = struct
+  type key = Cache.key
+
+  let tbl = Cache.create (get_initial_cache_size ())
+
+  let tag = ref ~-1
+
+  let mutex = Mutex.create ()
+
+  let hashcons node =
+    Mutex.lock mutex;
+    let v =
+      match Cache.find tbl node with
+      | exception Not_found ->
+        incr tag;
+        let tag = !tag in
+        let v = { tag; node } in
+        Cache.add tbl node v;
+        v
+      | v -> v
+    in
+    Mutex.unlock mutex;
+    v
+
+  let clear () =
+    Mutex.lock mutex;
+    Cache.clear tbl;
+    Mutex.unlock mutex
+
+  let stats () =
+    Mutex.lock mutex;
+    let stats = Cache.stats tbl in
+    Mutex.unlock mutex;
+    stats
+
+  let length () =
+    Mutex.lock mutex;
+    let len = Cache.length tbl in
+    Mutex.unlock mutex;
+    len
+end
+
+module Make (H : Hashtbl.HashedType) : S with type key = H.t =
+  Mk [@inlined hint] (Ephemeron.K1.Make [@inlined hint] (H))
+
+module Make_thread_safe (H : Hashtbl.HashedType) : S with type key = H.t =
+  Mk_thread_safe [@inlined hint] (Ephemeron.K1.Make [@inlined hint] (H))
+
+module Make_strong (H : Hashtbl.HashedType) : S with type key = H.t =
+  Mk [@inlined hint] (Hashtbl.Make [@inlined hint] (H))
+
+module Make_strong_thread_safe (H : Hashtbl.HashedType) :
+  S with type key = H.t =
+  Mk_thread_safe [@inlined hint] (Hashtbl.Make [@inlined hint] (H))
+
+module Fake (H : Hashtbl.HashedType) : S with type key = H.t =
+Mk [@inlined hint] (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)

src/hc.mli

@@ -0,0 +1,104 @@
+(** Hash-consing library.
+
+    The implementation is based on the paper
+    {{:https://dl.acm.org/doi/pdf/10.1145/1159876.1159880} Type-Safe Modular
+     Hash-Consing} by Jean-Christophe-Filliâtre and Sylvain Conchon.
+
+    The implementation should be multi-core safe. *)
+
+(** The type of hash-consed values. The [node] field is the actual value and
+    [tag] is a unique integer identifier. *)
+type +'a hash_consed = private
+  { node : 'a
+  ; tag : int
+  }
+
+(** The output signature of the various functors [Make], [MakeStrong], [Fake]
+    and [Mk]. *)
+module type S = sig
+  (** The type of value that are being hash-consed. *)
+  type key
+
+  (** Removes all elements from the table. *)
+  val clear : unit -> unit
+
+  (** [hashcons v] hash-cons the value [v], i.e. returns any existing value
+      equal to [v] that has already been hash-consed, if any; otherwise,
+      allocates a new hash-consed value with [v] as a node and returns it. As a
+      consequence the returned value is physically equal to any equal value
+      already hash-consed. *)
+  val hashcons : key -> key hash_consed
+
+  (** Return statistics about the hash-consing table. *)
+  val stats : unit -> Hashtbl.statistics
+
+  (** The number of hash-consed values. *)
+  val length : unit -> int
+end
+
+(** Hash-consing module using [Ephemeron.K1.Make] as a back-end cache. Not
+    thread-safe. *)
+module Make (H : Hashtbl.HashedType) : S with type key = H.t
+
+(** Hash-consing module using [Ephemeron.K1.Make] as a back-end cache.
+    Thread-safe. *)
+module Make_thread_safe (H : Hashtbl.HashedType) : S with type key = H.t
+
+(** Hash-consing module using [Hashtbl.Make] as a back-end cache. Not
+    thread-safe. *)
+module Make_strong (H : Hashtbl.HashedType) : S with type key = H.t
+
+(** Hash-consing module using [Hashtbl.Make] as a back-end cache. Thread-safe.
+*)
+module Make_strong_thread_safe (H : Hashtbl.HashedType) : S with type key = H.t
+
+(** Hash-consing module that does not perform hash-consing. This is useful to
+    easily benchmark the impact of hash-consing without having to change your
+    code too much: simply replace [Make] or [Makestrong] by [Fake]. *)
+module Fake (H : Hashtbl.HashedType) : S with type key = H.t
+
+(** The size that will be used to create a cache. *)
+val get_initial_cache_size : unit -> int
+
+(** Change the size that will be used to create a cache. *)
+val set_initial_cache_size : int -> unit
+
+(** Reset the size that will be used to create a cache to its default value. *)
+val reset_initial_cache_size : unit -> unit
+
+(** The type of custom cache modules. *)
+module type Cache = sig
+  (** The type of keys. *)
+  type key
+
+  (** The type of caches with ['a] values. *)
+  type !'a t
+
+  (** [create n] creates a new, empty cache, with initial size [n]. For best
+      results, [n] should be on the order of the expected number of elements
+      that will be in the cache. The cache must grow as needed, so [n] is just
+      an initial guess. *)
+  val create : int -> 'a t
+
+  (** Empty a cache. *)
+  val clear : 'a t -> unit
+
+  (** [add cache key v] adds a binding of [key] to [v] in cache [cache]. *)
+  val add : 'a t -> key -> 'a -> unit
+
+  (** [find cache v] returns the current binding of [v] in [cache], or must
+      raise [Not_found] if [v] is not in [cache]. *)
+  val find : 'a t -> key -> 'a
+
+  (** [length cache] returns the number of bindings in [cache]. *)
+  val length : 'a t -> int
+
+  (** [stats cache] return statistics about the cache [cache]. *)
+  val stats : 'a t -> Hashtbl.statistics
+end
+
+(** Hash-consing module using a custom user-defined cache. Not thread-safe. *)
+module Mk (Cache : Cache) : S with type key = Cache.key
+
+(** Hash-consing module using a custom user-defined cache. Thread-safe. *)
+module Mk_thread_safe (Cache : Cache) : S with type key = Cache.key

test/dune

@@ -0,0 +1,3 @@
+(test
+ (name test)
+ (libraries hc))

test/test.ml

@@ -0,0 +1,59 @@
+open Hc
+
+type hidden = view hash_consed
+
+and view =
+  | Leaf of int
+  | Node of int * hidden * hidden
+
+module H = struct
+  type t = view
+
+  let equal x y =
+    match (x, y) with
+    | Leaf m, Leaf n -> m = n
+    | Node (m, l1, r1), Node (n, l2, r2) -> m = n && l1 == l2 && r1 == r2
+    | _ -> false
+
+  let hash = function
+    | Leaf n -> n
+    | Node (n, l, r) -> (19 * ((19 * n) + l.tag)) + r.tag + 2
+end
+
+module HTree = Make (H)
+
+let leaf n = HTree.hashcons (Leaf n)
+
+let node v l h = HTree.hashcons (Node (v, l, h))
+
+let extract x = match x.node with Leaf x | Node (x, _, _) -> x
+
+let rec get_fibo n =
+  if n < 0 then failwith "get_fibo";
+  if n < 2 then leaf n
+  else
+    let a = get_fibo (n - 1) in
+    let b = get_fibo (n - 2) in
+    node (extract a + extract b) a b
+
+let () =
+  (* 1 *)
+  let n1 = leaf 1 in
+  let n2 = leaf 2 in
+  let n3 = node 3 n1 n2 in
+  let n3' = node 3 n1 n2 in
+  assert (n3 == n3');
+  let n4 = node 4 n3 n3' in
+  let n4' = node 4 n3' n3 in
+  assert (n4 == n4');
+  let s = HTree.stats () in
+  assert (s.num_bindings = 4);
+  (* 2 *)
+  HTree.clear ();
+  let n = 30 in
+  let g = get_fibo n in
+  let s = HTree.stats () in
+  assert (s.num_bindings = n + 1);
+  let res = extract g in
+  assert (res = 832040);
+  Format.printf "Tests are OK !@."