From c829d1f7fe7efef5ccd8092ae4867d03ac6dcdf1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 20 Nov 2013 12:33:59 +0100 Subject: [PATCH] updated caches to handle exceptions --- cache.ml | 86 ++++++++++++++++++++++++++++++++++++------------------- cache.mli | 10 +++++-- 2 files changed, 65 insertions(+), 31 deletions(-) diff --git a/cache.ml b/cache.ml index 373d0140..4f9a94f5 100644 --- a/cache.ml +++ b/cache.ml @@ -47,11 +47,16 @@ module type S = sig (** Clear content of the cache *) val with_cache : 'a t -> (key -> 'a) -> key -> 'a - (** Wrap the function with the cache *) + (** Wrap the function with the cache. This means that + [with_cache cache f x] always returns the same value as + [f x], if [f x] returns, or raise the same exception. + However, [f] may not be called if [x] is in the cache. *) val with_cache_rec : 'a t -> ((key -> 'a) -> key -> 'a) -> key -> 'a (** Partially apply the given function with a cached version of itself. - It returns the specialized function. *) + It returns the specialized function. + [with_cache_rec cache f] applies [f] to a cached version of [f], + called [f'], so that [f' x = f f' x]. *) end (** Signature of a cache for pairs of values *) @@ -106,7 +111,7 @@ end module Linear(X : EQ) = struct type 'a t = 'a bucket array - and 'a bucket = Empty | Pair of key * 'a + and 'a bucket = Empty | Pair of key * 'a | PairRaise of key * exn and key = X.t let create size = @@ -116,12 +121,12 @@ module Linear(X : EQ) = struct let clear cache = Array.fill cache 0 (Array.length cache) Empty - (** Insert the binding (x -> y) into the cache *) - let insert cache x y = + (** Insert the bucket [b] into the cache *) + let insert cache b = let n = Array.length cache in (* shift other values toward the end *) Array.blit cache 0 cache 1 (n-1); - cache.(0) <- Pair(x,y) + cache.(0) <- b (** Try to find [f x] in the cache, otherwise compute it and cache the result *) @@ -131,12 +136,17 @@ module Linear(X : EQ) = struct (* function that performs the lookup *) if i = n then begin (* cache miss *) - let y = f x in - insert cache x y; - y + try + let y = f x in + insert cache (Pair (x, y)); + y + with e -> + insert cache (PairRaise (x, e)); + raise e end else match cache.(i) with | Pair (x',y) when X.equal x x' -> y - | Empty | Pair _ -> search (i+1) + | PairRaise (x', e) when X.equal x x' -> raise e + | _ -> search (i+1) in search 0 @@ -148,7 +158,7 @@ end module Linear2(X : EQ)(Y : EQ) = struct type 'a t = 'a bucket array - and 'a bucket = Empty | Assoc of key1 * key2 * 'a + and 'a bucket = Empty | Assoc of key1 * key2 * 'a | AssocRaise of key1 * key2 * exn and key1 = X.t and key2 = Y.t @@ -159,12 +169,12 @@ module Linear2(X : EQ)(Y : EQ) = struct let clear cache = Array.fill cache 0 (Array.length cache) Empty - (** Insert the binding (x -> y) into the cache *) - let insert cache x1 x2 y = + (** Insert the binding [b] into the cache *) + let insert cache b = let n = Array.length cache in (* shift other values toward the end *) Array.blit cache 0 cache 1 (n-1); - cache.(0) <- Assoc(x1,x2,y) + cache.(0) <- b (** Try to find [f x] in the cache, otherwise compute it and cache the result *) @@ -174,12 +184,17 @@ module Linear2(X : EQ)(Y : EQ) = struct (* function that performs the lookup *) if i = n then begin (* cache miss *) - let y = f x1 x2 in - insert cache x1 x2 y; - y + try + let y = f x1 x2 in + insert cache (Assoc (x1, x2, y)); + y + with e -> + insert cache (AssocRaise (x1, x2, e)); + raise e end else match cache.(i) with | Assoc (x1',x2',y) when X.equal x1 x1' && Y.equal x2 x2' -> y - | Empty | Assoc _ -> search (i+1) + | AssocRaise (x1',x2',e) when X.equal x1 x1' && Y.equal x2 x2' -> raise e + | _ -> search (i+1) in search 0 end @@ -196,7 +211,7 @@ module Replacing(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 * 'a + and 'a bucket = Empty | Assoc of key * 'a | AssocRaise of key * exn let create size = Array.create size Empty @@ -211,10 +226,16 @@ module Replacing(X : HASH) = struct match c.(i) with | Assoc (x', y) when X.equal x x' -> y (* cache hit *) - | Assoc _ | Empty -> (* cache miss *) - let y = f x in - c.(i) <- Assoc (x, y); - y + | AssocRaise (x', e) when X.equal x x' -> + raise e (* cache hit *) + | _ -> (* cache miss *) + try + let y = f x in + c.(i) <- Assoc (x, y); + y + with e -> + c.(i) <- AssocRaise (x, e); + raise e let with_cache_rec cache f x = (* make a recursive version of [f] that uses the cache *) @@ -230,11 +251,10 @@ module Replacing2(X : HASH)(Y : 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 key1 * key2 * 'a + and 'a bucket = Empty | Assoc of key1 * key2 * 'a | AssocRaise of key1 * key2 * exn and key1 = X.t and key2 = Y.t - let create size = Array.create size Empty @@ -246,14 +266,22 @@ module Replacing2(X : HASH)(Y : HASH) = struct match c.(i) with | 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 - c.(i) <- Assoc (x1, x2, y); - y + | AssocRaise (x1', x2', e) when X.equal x1 x1' && Y.equal x2 x2' -> + raise e (* cache hit *) + | _ -> (* cache miss *) + try + let y = f x1 x2 in + c.(i) <- Assoc (x1, x2, y); + y + with e -> + c.(i) <- AssocRaise (x1, x2, e); + raise e end (** {2 Hashtables with Least Recently Used eviction policy *) +(* TODO: handle exceptions *) + module LRU(X : HASH) = struct type key = X.t diff --git a/cache.mli b/cache.mli index 01049cf8..63637a44 100644 --- a/cache.mli +++ b/cache.mli @@ -49,11 +49,16 @@ module type S = sig (** Clear content of the cache *) val with_cache : 'a t -> (key -> 'a) -> key -> 'a - (** Wrap the function with the cache *) + (** Wrap the function with the cache. This means that + [with_cache cache f x] always returns the same value as + [f x], if [f x] returns, or raise the same exception. + However, [f] may not be called if [x] is in the cache. *) val with_cache_rec : 'a t -> ((key -> 'a) -> key -> 'a) -> key -> 'a (** Partially apply the given function with a cached version of itself. - It returns the specialized function. *) + It returns the specialized function. + [with_cache_rec cache f] applies [f] to a cached version of [f], + called [f'], so that [f' x = f f' x]. *) end (** Signature of a cache for pairs of values *) @@ -97,5 +102,6 @@ module Replacing2(X : HASH)(Y : HASH) : S2 with type key1 = X.t and type key2 = module LRU(X : HASH) : S with type key = X.t +(* TODO exception handling in LRU *) (* TODO LRU2 *)