From 694b4929b0f2fdb03b3eb708fedacdfcf04f6aed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 6 Mar 2013 15:14:48 +0100 Subject: [PATCH] Cache.S2 can cache pair of heterogeneous arguments; Cache.Dummy and Cache.Dummy2 (no caching); benchmarking Cache --- cache.ml | 84 +++++++++++++++++++++++++++++++++++++++---------- cache.mli | 20 +++++++++--- tests/benchs.ml | 43 +++++++++++++++++++++++++ 3 files changed, 127 insertions(+), 20 deletions(-) diff --git a/cache.ml b/cache.ml index 2d01a8b2..0017452c 100644 --- a/cache.ml +++ b/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 *) - let y = f x in - insert cache x y; - y + (* cache miss *) + let y = f x in + insert cache x 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 key = X.t + and 'a bucket = Empty | Assoc of key1 * key2 * 'a + 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 - type key = X.t - +module Replacing2(X : HASH)(Y : HASH) = struct (** 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 diff --git a/cache.mli b/cache.mli index 06068a89..c49b905d 100644 --- a/cache.mli +++ b/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 *) diff --git a/tests/benchs.ml b/tests/benchs.ml index 4c15ca1c..0abcaa2a 100644 --- a/tests/benchs.ml +++ b/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