first commit

.gitignore

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

.ocamlformat

@@ -0,0 +1,16 @@
+version=0.11.0
+break-sequences=true
+doc-comments=before
+field-space=loose
+let-and=sparse
+sequence-style=terminator
+type-decl=sparse
+wrap-comments=true
+if-then-else=k-r
+let-and=sparse
+space-around-records
+space-around-lists
+space-around-arrays
+cases-exp-indent=2
+max-indent=2
+break-cases=all

LICENSE.md

@@ -0,0 +1,8 @@
+The ISC License (ISC)
+=====================
+
+Copyright © 2019, Léo Andrès
+
+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,77 @@
+# Hashcons
+
+Hashcons is an [OCaml] library for [hash consing].
+
+## Usage
+
+TODO
+
+## Build
+
+To build the library:
+
+```sh
+scripts/build.sh
+```
+
+To clean after building:
+
+```sh
+scripts/clean.sh
+```
+
+## Documentation
+
+To build the documentation:
+
+```sh
+scripts/doc.sh
+```
+
+You can open it in your browser using:
+
+```sh
+scripts/view_doc.sh
+```
+
+## Tests
+
+To run the tests:
+
+```sh
+scripts/test.sh
+```
+
+To run the tests with coverage report:
+
+```sh
+scripts/coverage.sh
+```
+
+You can open the tests coverage report in your web browser using:
+
+```sh
+scripts/view_coverage.sh
+```
+
+## Format
+
+You can format the code using:
+
+```sh
+scripts/format.sh
+```
+
+## License
+
+See [LICENSE].
+
+## Changelog
+
+See [CHANGELOG].
+
+[CHANGELOG]: ./CHANGELOG.md
+[LICENSE]: ./LICENSE.md
+
+[hash consing]: https://en.wikipedia.org/wiki/Hash_consing
+[OCaml]: https://en.wikipedia.org/wiki/OCaml

dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.11)
+(name memo)
+(explicit_js_mode)

hashcons.opam

@@ -0,0 +1,23 @@
+opam-version: "2.0"
+
+synopsis: "Hash consing library"
+
+version: "dev"
+license: "ISC"
+homepage: "https://git.zapashcanon.fr/zapashcanon/hashcons"
+bug-reports: "https://git.zapashcanon.fr/zapashcanon/hashcons/issues"
+
+authors: "Léo Andrès (zapashcanon) <leo@ndrs.fr>"
+maintainer: "Léo Andrès (zapashcanon) <leo@ndrs.fr>"
+dev-repo: "git+https://git.zapashcanon.fr/zapashcanon/hashcons.git"
+
+depends: [
+  "ocaml"
+  "dune" {>= "1.11.0"}
+]
+
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+]
+
+description: "Hashcons is a library for hash consing."

scripts/build.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  eval "$(opam env)"
+  dune build @all )

scripts/clean.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  eval "$(opam env)"
+  dune clean )

scripts/coverage.sh

@@ -0,0 +1,12 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  scripts/clean.sh
+  eval "$(opam env)"
+  coverage=_coverage
+  rm -f "$(find . -name 'bisect*.out')" || true
+  rm -rf $coverage
+  BISECT_ENABLE=YES dune runtest --no-buffer --force > /dev/null
+  bisect-ppx-report -html $coverage/ "$(find . -name 'bisect*.out')" )

scripts/doc.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  eval "$(opam env)"
+  dune build @doc )

scripts/format.sh

@@ -0,0 +1,8 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  eval "$(opam env)"
+  ocamlformat -i src/*.ml
+  ocamlformat -i test/*.ml )

scripts/test.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  eval "$(opam env)"
+  dune runtest )

scripts/view_coverage.sh

@@ -0,0 +1,9 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  scripts/clean.sh
+  eval "$(opam env)"
+  coverage=_coverage
+  xdg-open $coverage/index.html )

scripts/view_doc.sh

@@ -0,0 +1,7 @@
+#!/bin/sh
+
+set -eu
+
+( cd "$(dirname "$0")/../"
+  doc=_build/default/_doc/_html
+  xdg-open $doc/index.html )

src/dune

@@ -0,0 +1,5 @@
+(library
+  (name hashcons)
+  (public_name hashcons)
+  (wrapped false)
+  (preprocess (pps bisect_ppx -conditional)))

src/hashcons.ml

@@ -0,0 +1,45 @@
+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 Mk (Cache : Hashtbl.S) = struct
+  type t = Cache.key hash_consed Cache.t
+
+  let tbl = Cache.create (get_initial_cache_size ())
+
+  let clear () = Cache.clear tbl
+
+  let iter f = Cache.iter f tbl
+
+  let stats () = Cache.stats tbl
+
+  let hashcons =
+    let gen =
+      let count = ref (-1) in
+      fun () ->
+        incr count;
+        !count
+    in
+    fun k ->
+      try Cache.find tbl k
+      with Not_found ->
+        let v = { tag = gen (); node = k } in
+        Cache.add tbl k v;
+        v
+end
+
+module Make (H : Hashtbl.HashedType) = struct
+  include Mk (Ephemeron.K1.Make (H))
+end
+
+module MakeStrong (H : Hashtbl.HashedType) = struct
+  include Mk (Hashtbl.Make (H))
+end

test/dune

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

test/test.ml

@@ -0,0 +1,64 @@
+open Hashcons
+
+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 !@."