Handle sharing of Index instances explicitly

CHANGES.md

@@ -1,3 +1,11 @@
+# Unreleased
+
+## Changed
+
+- Caching of `Index` instances is now explicit: `Index.Make` requires a cache
+  implementation, and `Index.v` may be passed a cache to be used for instance
+  sharing. The default behaviour is _not_ to share instances. (#188)
+
 # 1.2.1 (2020-06-24)
 
 ## Added

README.md

@@ -7,8 +7,9 @@ Index is a scalable implementation of persistent indices in OCaml.
 
 It takes an arbitrary IO implementation and user-supplied content types 
 and supplies a standard key-value interface for persistent storage. 
-Index provides instance sharing by default: 
-each OCaml run-time shares a common singleton instance.
+
+Index supports instance sharing:
+each OCaml runtime can share a common singleton instance.
 
 Index supports multiple-reader/single-writer access.
 Concurrent access is safely managed using lock files.

bench/bench.ml

@@ -151,7 +151,8 @@ let absent_bindings_pool = ref [||]
 let sorted_bindings_pool = ref [||]
 
 module Index = struct
-  module Index = Index_unix.Private.Make (Context.Key) (Context.Value)
+  module Index =
+    Index_unix.Private.Make (Context.Key) (Context.Value) (Index.Cache.Noop)
 
   let add_metrics =
     let no_tags x = x in
@@ -211,7 +212,10 @@ module Index = struct
     read_absent ~with_metrics !absent_bindings_pool t
 
   let run ~with_metrics ~nb_entries ~log_size ~root ~name ~fresh ~readonly b =
-    let index = Index.v ~fresh ~readonly ~log_size (root // name) in
+    let index =
+      Index.v ~cache:(Index.empty_cache ()) ~fresh ~readonly ~log_size
+        (root // name)
+    in
     let result = Benchmark.run ~nb_entries (b ~with_metrics index) in
     Index.close index;
     result

index.opam

@@ -35,8 +35,8 @@ Index is a scalable implementation of persistent indices in OCaml.
 
 It takes an arbitrary IO implementation and user-supplied content
 types and supplies a standard key-value interface for persistent
-storage. Index provides instance sharing by default: each OCaml
-run-time shares a common singleton instance.
+storage. Index provides instance sharing: each OCaml
+run-time can share a common singleton instance.
 
 Index supports multiple-reader/single-writer access. Concurrent access
 is safely managed using lock files."""

src/cache.ml

@@ -0,0 +1,52 @@
+(* The MIT License
+
+Copyright (c) 2019 Craig Ferguson <[email protected]>
+                   Thomas Gazagnaire <[email protected]>
+                   Ioana Cristescu <[email protected]>
+                   Clément Pascutto <[email protected]>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software. *)
+
+module type S = sig
+  type ('k, 'v) t
+  (** A cache of values of type ['v], indexed by keys of type ['k]. *)
+
+  val create : unit -> (_, _) t
+
+  val add : ('k, 'v) t -> 'k -> 'v -> unit
+
+  val find : ('k, 'v) t -> 'k -> 'v option
+
+  val remove : ('k, _) t -> 'k -> unit
+end
+
+(** Cache implementation that always misses. *)
+module Noop : S = struct
+  type (_, _) t = unit
+
+  let create () = ()
+
+  let add () _ _ = ()
+
+  let find () _ = None
+
+  let remove () _ = ()
+end
+
+(** Cache implementation that always finds previously-added values, and grows
+    indefinitely. *)
+module Unbounded : S = struct
+  include Hashtbl
+
+  let create () = create 0
+
+  let find = find_opt
+end

src/index.ml

@@ -17,6 +17,7 @@ all copies or substantial portions of the Software. *)
 
 include Index_intf
 module Stats = Stats
+module Cache = Cache
 
 let may f = function None -> () | Some bf -> f bf
 
@@ -31,7 +32,8 @@ module Make_private
     (V : Value)
     (IO : Io.S)
     (Mutex : MUTEX)
-    (Thread : THREAD) =
+    (Thread : THREAD)
+    (Cache : Cache.S) =
 struct
   type 'a async = 'a Thread.t
 
@@ -219,36 +221,9 @@ struct
           Int64.of_float rounded
       end)
 
-  let with_cache ~v ~clear =
-    let roots = Hashtbl.create 0 in
-    let f ?(fresh = false) ?(readonly = false) ~log_size root =
-      Log.info (fun l ->
-          l "[%s] v fresh=%b readonly=%b log_size=%d" (Filename.basename root)
-            fresh readonly log_size);
-      try
-        if not (Sys.file_exists (index_dir root)) then (
-          Log.debug (fun l ->
-              l "[%s] does not exist anymore, cleaning up the fd cache"
-                (Filename.basename root));
-          Hashtbl.remove roots (root, true);
-          Hashtbl.remove roots (root, false);
-          raise Not_found );
-        let t = Hashtbl.find roots (root, readonly) in
-        if t.open_instances <> 0 then (
-          Log.debug (fun l -> l "[%s] found in cache" (Filename.basename root));
-          t.open_instances <- t.open_instances + 1;
-          let t = ref (Some t) in
-          if fresh then clear t;
-          t )
-        else (
-          Hashtbl.remove roots (root, readonly);
-          raise Not_found )
-      with Not_found ->
-        let instance = v ~fresh ~readonly ~log_size root in
-        Hashtbl.add roots (root, readonly) instance;
-        ref (Some instance)
-    in
-    `Staged f
+  type cache = (string * bool, instance) Cache.t
+
+  let empty_cache = Cache.create
 
   let v_no_cache ~fresh ~readonly ~log_size root =
     Log.debug (fun l ->
@@ -330,7 +305,39 @@ struct
       pending_cancel = false;
     }
 
-  let (`Staged v) = with_cache ~v:v_no_cache ~clear
+  let v ?(cache = empty_cache ()) ?(fresh = false) ?(readonly = false) ~log_size
+      root =
+    let new_instance () =
+      let instance = v_no_cache ~fresh ~readonly ~log_size root in
+      Cache.add cache (root, readonly) instance;
+      ref (Some instance)
+    in
+    Log.info (fun l ->
+        l "[%s] v fresh=%b readonly=%b log_size=%d" (Filename.basename root)
+          fresh readonly log_size);
+    match
+      (Cache.find cache (root, readonly), Sys.file_exists (index_dir root))
+    with
+    | None, _ -> new_instance ()
+    | Some _, false ->
+        Log.debug (fun l ->
+            l "[%s] does not exist anymore, cleaning up the fd cache"
+              (Filename.basename root));
+        Cache.remove cache (root, true);
+        Cache.remove cache (root, false);
+        new_instance ()
+    | Some t, true -> (
+        match t.open_instances with
+        | 0 ->
+            Cache.remove cache (root, readonly);
+            new_instance ()
+        | _ ->
+            Log.debug (fun l ->
+                l "[%s] found in cache" (Filename.basename root));
+            t.open_instances <- t.open_instances + 1;
+            let t = ref (Some t) in
+            if fresh then clear t;
+            t )
 
   let interpolation_search index key =
     let hashed_key = K.hash key in

src/index_intf.ml

@@ -114,9 +114,17 @@ module type S = sig
   type value
   (** The type for values. *)
 
-  val v : ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t
+  type cache
+  (** The type for caches of index instances. *)
+
+  val empty_cache : unit -> cache
+  (** Construct a new empty cache of index instances. *)
+
+  val v :
+    ?cache:cache -> ?fresh:bool -> ?readonly:bool -> log_size:int -> string -> t
   (** The constructor for indexes.
 
+      @param cache a cache instance to use for instance sharing.
       @param fresh whether an existing index should be overwritten.
       @param read_only whether read-only mode is enabled for this index.
       @param log_size the maximum number of bindings in the `log` IO. *)
@@ -162,7 +170,7 @@ module type S = sig
 end
 
 module type Index = sig
-  (** The input of [Make] for keys. *)
+  (** The input of {!Make} for keys. *)
   module type Key = sig
     (* N.B. We use [sig ... end] redirections to avoid linking to the [_intf]
        file in the generated docs. Once Odoc 2 is released, this can be
@@ -172,12 +180,8 @@ module type Index = sig
     (** @inline *)
   end
 
-  module Stats : sig
-    include module type of Stats
-    (** @inline *)
-  end
-
-  (** The input of [Make] for values. The same requirements as for [Key] apply. *)
+  (** The input of {!Make} for values. The same requirements as for {!Key}
+      apply. *)
   module type Value = sig
     include Value
     (** @inline *)
@@ -198,6 +202,13 @@ module type Index = sig
     (** @inline *)
   end
 
+  (** Signatures and implementations of caches. {!Make} requires a cache in
+      order to provide instance sharing. *)
+  module Cache : sig
+    include module type of Cache
+    (** @inline *)
+  end
+
   (** Index module signature. *)
   module type S = sig
     include S
@@ -212,8 +223,19 @@ module type Index = sig
   (** The exception raised when any operation is attempted on a closed index,
       except for [close], which is idempotent. *)
 
-  module Make (K : Key) (V : Value) (IO : IO) (M : MUTEX) (T : THREAD) :
-    S with type key = K.t and type value = V.t
+  module Make
+      (K : Key)
+      (V : Value)
+      (IO : IO)
+      (M : MUTEX)
+      (T : THREAD)
+      (C : Cache.S) : S with type key = K.t and type value = V.t
+
+  (** Run-time metric tracking for index instances. *)
+  module Stats : sig
+    include module type of Stats
+    (** @inline *)
+  end
 
   (** These modules should not be used. They are exposed purely for testing
       purposes. *)
@@ -263,7 +285,12 @@ module type Index = sig
           is timed. *)
     end
 
-    module Make (K : Key) (V : Value) (IO : IO) (M : MUTEX) (T : THREAD) :
-      S with type key = K.t and type value = V.t
+    module Make
+        (K : Key)
+        (V : Value)
+        (_ : IO)
+        (_ : MUTEX)
+        (_ : THREAD)
+        (_ : Cache.S) : S with type key = K.t and type value = V.t
   end
 end

src/unix/index_unix.mli

@@ -15,7 +15,7 @@ furnished to do so, subject to the following conditions:
 The above copyright notice and this permission notice shall be included in
 all copies or substantial portions of the Software. *)
 
-module Make (K : Index.Key) (V : Index.Value) :
+module Make (K : Index.Key) (V : Index.Value) (C : Index.Cache.S) :
   Index.S with type key = K.t and type value = V.t
 
 module Syscalls = Syscalls
@@ -28,6 +28,6 @@ module Private : sig
 
   module Raw = Raw
 
-  module Make (K : Index.Key) (V : Index.Value) :
+  module Make (K : Index.Key) (V : Index.Value) (C : Index.Cache.S) :
     Index.Private.S with type key = K.t and type value = V.t
 end

test/cache.ml

@@ -0,0 +1,31 @@
+let check_none msg = Alcotest.(check (option reject)) msg None
+
+let check_some msg x = Alcotest.(check (option int)) msg (Some x)
+
+let test_noop () =
+  let open Index.Cache.Noop in
+  (* Test that added entries are never found. *)
+  let c = create () in
+  find c "not-added" |> check_none "Cannot find non-existent value";
+  add c "added" 1;
+  find c "added" |> check_none "Cannot find added value";
+  remove c "added";
+  find c "added" |> check_none "Can't find added value after remove";
+  ()
+
+let test_unbounded () =
+  let open Index.Cache.Unbounded in
+  (* Test that added entries are always found. *)
+  let c = create () in
+  find c "not-added" |> check_none "Cannot find non-existent value";
+  add c "added" 1;
+  find c "added" |> check_some "Can find added value" 1;
+  remove c "added";
+  find c "added" |> check_none "Can't find added value after remove";
+  ()
+
+let tests =
+  [
+    Alcotest.test_case "noop" `Quick test_noop;
+    Alcotest.test_case "unbounded" `Quick test_unbounded;
+  ]

test/dune

@@ -1,4 +1,4 @@
 (test
- (name search)
+ (name main)
  (package index)
  (libraries index alcotest))

test/main.ml

@@ -0,0 +1,2 @@
+let () =
+  Alcotest.run "index" [ ("cache", Cache.tests); ("search", Search.tests) ]

test/search.ml

@@ -98,14 +98,10 @@ let interpolation_constant_metric () =
       |> Alcotest.(check string) "" v)
     array
 
-let () =
-  Random.self_init ();
-  Alcotest.run "search"
-    [
-      ( "interpolation",
-        [
-          Alcotest.test_case "unique" `Quick interpolation_unique;
-          Alcotest.test_case "constant metric" `Quick
-            interpolation_constant_metric;
-        ] );
-    ]
+let tests =
+  [
+    Alcotest.test_case "unique" `Quick interpolation_unique;
+    Alcotest.test_case "constant metric" `Quick interpolation_constant_metric;
+  ]
+
+let () = Random.self_init ()