Cache.S2 can cache pair of heterogeneous arguments;

Cache.Dummy and Cache.Dummy2 (no caching);
benchmarking Cache

cache.ml

@@ -48,12 +48,18 @@ module type S = sig
 
   val with_cache : 'a t -> (key -> 'a) -> key -> 'a
     (** Wrap the function with the cache *)
+
+  val with_cache_rec : int -> ((key -> 'a) -> key -> 'a) -> ('a t * (key -> 'a))
+    (** Partially apply the given function with a cached version of itself.
+        The cache has as size the first (int) argument.
+        It returns both the cache, and the specialized function *)
 end
 
 (** Signature of a cache for pairs of values *)
 module type S2 = sig
   type 'a t
-  type key
+  type key1
+  type key2
 
   val create : int -> 'a t
     (** Create a new cache of the given size. *)
@@ -61,10 +67,38 @@ module type S2 = sig
   val clear : 'a t -> unit
     (** Clear content of the cache *)
 
-  val with_cache : 'a t -> (key -> key -> 'a) -> key -> key -> 'a
+  val with_cache : 'a t -> (key1 -> key2 -> 'a) -> key1 -> key2 -> 'a
     (** Wrap the function with the cache *)
 end
 
+(** {2 Dummy cache (no caching) *)
+
+module Dummy(X : sig type t end) = struct
+  type 'a t = unit
+  and key = X.t
+
+  let create size = ()
+
+  let clear () = ()
+
+  let with_cache () f x = f x
+
+  let with_cache_rec size f =
+    let rec f' x = f f' x in
+    (), f'
+end
+
+module Dummy2(X : sig type t end)(Y : sig type t end) = struct
+  type 'a t = unit
+  and key1 = X.t
+  and key2 = Y.t
+
+  let create size = ()
+
+  let clear () = ()
+
+  let with_cache () f x1 x2 = f x1 x2
+end
 
 (** {2 Small linear cache} *)
 
@@ -97,21 +131,30 @@ module Linear(X : EQ) = struct
     let rec search i =
       (* function that performs the lookup *)
       if i = n then begin
-          (* cache miss *)
+        (* cache miss *)
-          let y = f x in
+        let y = f x in
-          insert cache x y;
+        insert cache x y;
-          y
+        y
       end else match cache.(i) with
       | Pair (x',y) when X.equal x x' -> y
       | Empty | Pair _ -> search (i+1)
     in
     search 0
+
+  (** Partially apply the given function with a new cache of the
+      given size. It returns both the cache, and the specialized function *)
+  let with_cache_rec size f =
+    let cache = create size in
+    (* make a recursive version of [f] that uses the cache *)
+    let rec f' x = with_cache cache (fun x -> f f' x) x in
+    cache, f'
 end
 
-module Linear2(X : EQ) = struct
+module Linear2(X : EQ)(Y : EQ) = struct
   type 'a t = 'a bucket array
-  and 'a bucket = Empty | Assoc of key * key * 'a
+  and 'a bucket = Empty | Assoc of key1 * key2 * 'a
-  and key = X.t
+  and key1 = X.t
+  and key2 = Y.t
 
   let create size =
     assert (size >= 1);
@@ -139,7 +182,7 @@ module Linear2(X : EQ) = struct
           insert cache x1 x2 y;
           y
       end else match cache.(i) with
-      | Assoc (x1',x2',y) when X.equal x1 x1' && X.equal x2 x2' -> y
+      | Assoc (x1',x2',y) when X.equal x1 x1' && Y.equal x2 x2' -> y
       | Empty | Assoc _ -> search (i+1)
     in
     search 0
@@ -174,11 +217,17 @@ module Replacing(X : HASH) = struct
       let y = f x in
       c.(i) <- Assoc (x, y);
       y
+
+  (** Partially apply the given function with a new cache of the
+      given size. It returns both the cache, and the specialized function *)
+  let with_cache_rec size f =
+    let cache = create size in
+    (* make a recursive version of [f] that uses the cache *)
+    let rec f' x = with_cache cache (fun x -> f f' x) x in
+    cache, f'
 end
 
-module Replacing2(X : HASH) = struct
+module Replacing2(X : HASH)(Y : HASH) = struct
-  type key = X.t
-
   (** A slot of the array contains a (key, value, true)
       if key->value is stored there (at index hash(key) % length),
       (null, null, false) otherwise.
@@ -186,7 +235,10 @@ module Replacing2(X : HASH) = struct
       The first slot in the array contains the function
       used to produce the value upon a cache miss. *)
   type 'a t = 'a bucket array
-  and 'a bucket = Empty | Assoc of key * key * 'a
+  and 'a bucket = Empty | Assoc of key1 * key2 * 'a
+  and key1 = X.t
+  and key2 = Y.t
+
 
   let create size =
     Array.create size Empty
@@ -195,9 +247,9 @@ module Replacing2(X : HASH) = struct
     Array.fill c 0 (Array.length c) Empty
 
   let with_cache c f x1 x2 =
-    let i = (((X.hash x1 + 17) lxor X.hash x2) mod Array.length c) in
+    let i = (((X.hash x1 + 17) lxor Y.hash x2) mod Array.length c) in
     match c.(i) with
-    | Assoc (x1', x2', y) when X.equal x1 x1' && X.equal x2 x2' ->
+    | Assoc (x1', x2', y) when X.equal x1 x1' && Y.equal x2 x2' ->
       y (* cache hit *)
     | Assoc _ | Empty -> (* cache miss *)
       let y = f x1 x2 in

cache.mli

@@ -50,12 +50,18 @@ module type S = sig
 
   val with_cache : 'a t -> (key -> 'a) -> key -> 'a
     (** Wrap the function with the cache *)
+
+  val with_cache_rec : int -> ((key -> 'a) -> key -> 'a) -> ('a t * (key -> 'a))
+    (** Partially apply the given function with a cached version of itself.
+        The cache has as size the first (int) argument.
+        It returns both the cache, and the specialized function *)
 end
 
 (** Signature of a cache for pairs of values *)
 module type S2 = sig
   type 'a t
-  type key
+  type key1
+  type key2
 
   val create : int -> 'a t
     (** Create a new cache of the given size. *)
@@ -63,10 +69,16 @@ module type S2 = sig
   val clear : 'a t -> unit
     (** Clear content of the cache *)
 
-  val with_cache : 'a t -> (key -> key -> 'a) -> key -> key -> 'a
+  val with_cache : 'a t -> (key1 -> key2 -> 'a) -> key1 -> key2 -> 'a
     (** Wrap the function with the cache *)
 end
 
+(** {2 Dummy cache (no caching) *)
+
+module Dummy(X : sig type t end) : S with type key = X.t
+
+module Dummy2(X : sig type t end)(Y : sig type t end) : S2 with type key1 = X.t and type key2 = Y.t
+
 (** {2 Small linear cache} *)
 
 (** This cache stores (key,value) pairs in an array, that is traversed
@@ -74,13 +86,13 @@ end
 
 module Linear(X : EQ) : S with type key = X.t
 
-module Linear2(X : EQ) : S2 with type key = X.t
+module Linear2(X : EQ)(Y : EQ) : S2 with type key1 = X.t and type key2 = Y.t
 
 (** {2 Hashtables that resolve collisions by replacing} *)
 
 module Replacing(X : HASH) : S with type key = X.t
 
-module Replacing2(X : HASH) : S2 with type key = X.t
+module Replacing2(X : HASH)(Y : HASH) : S2 with type key1 = X.t and type key2 = Y.t
 
 (* TODO LRU cache *)
 

tests/benchs.ml

@@ -1,6 +1,49 @@
 
 (** Benchmarking *)
 
+(** {2 Cache} *)
+
+(** Cached fibonacci function *)
+module Fibo(C : Cache.S with type key = int) = struct
+  let fib ~size =
+    let rec fib fib' n =
+      match n with
+      | 0 -> 1
+      | 1 -> 1
+      | n ->
+        fib' (n-1) + fib' (n-2)
+    in
+    let _cache, cached_fib = C.with_cache_rec size fib in
+    cached_fib
+end
+
+let _ =
+  let module LinearIntCache = Cache.Linear(struct
+    type t = int
+    let equal i j = i = j
+  end) in
+  let module ReplacingIntCache = Cache.Replacing(struct
+    type t = int
+    let equal i j = i = j
+    let hash i = i
+  end) in
+  let module DummyIntCache = Cache.Dummy(struct type t = int end) in
+  (* Fibonacci for those caching implementations *)
+  let module LinearFibo = Fibo(LinearIntCache) in
+  let module ReplacingFibo = Fibo(ReplacingIntCache) in
+  let module DummyFibo = Fibo(DummyIntCache) in
+  (* benchmark caches with fibo function *)
+  let bench_fib fib () = 
+    ignore (List.map fib [5;10;20;30;35])
+  in
+  Bench.bench
+    [ "linear_fib", bench_fib (LinearFibo.fib ~size:5);
+      "replacing_fib", bench_fib (ReplacingFibo.fib ~size:128);
+      "dummy_fib", bench_fib (DummyFibo.fib ~size:5);
+    ]
+
+(** {2 PHashtbl} *)
+
 module IHashtbl = Hashtbl.Make(struct
   type t = int
   let equal i j = i - j = 0