From 001e28ad5fe11ea22f9e27395fa38095f8a8b88f Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Wed, 6 Mar 2013 15:43:54 +0100
Subject: [PATCH] LRU cache implemented

---
 cache.ml        | 104 ++++++++++++++++++++++++++++++++++++++++++++++++
 cache.mli       |   6 ++-
 tests/benchs.ml |  39 ++++++++++++------
 3 files changed, 135 insertions(+), 14 deletions(-)

diff --git a/cache.ml b/cache.ml
index 0017452c..4b581ff6 100644
--- a/cache.ml
+++ b/cache.ml
@@ -208,6 +208,8 @@ module Replacing(X : HASH) = struct
   let clear c =
     Array.fill c 0 (Array.length c) Empty
 
+  (** Try to find [f x] in the cache, otherwise compute it
+      and cache the result *)
   let with_cache c f x =
     let i = (X.hash x) mod (Array.length c) in
     match c.(i) with
@@ -256,3 +258,105 @@ module Replacing2(X : HASH)(Y : HASH) = struct
       c.(i) <- Assoc (x1, x2, y);
       y
 end
+
+(** {2 Hashtables with Least Recently Used eviction policy *)
+
+module LRU(X : HASH) = struct
+  type key = X.t
+
+  module H = Hashtbl.Make(X)
+
+  type 'a t = {
+    table : 'a node H.t;  (* hashtable key -> node *)
+    first : 'a node;      (* dummy node for the entry of the list *)
+    mutable len : int;    (* number of entries *)
+    size : int;           (* max size *)
+  }
+  and 'a node = {
+    mutable key : key;
+    mutable value : 'a;
+    mutable next : 'a node;
+    mutable prev : 'a node;
+  } (** Meta data for the value *)
+
+  let create size =
+    let rec first = 
+      { key = Obj.magic 0; value = Obj.magic 0; next=first; prev=first; }
+    in
+    { table = H.create size;
+      len = 0;
+      size;
+      first;
+    }
+
+  (** Clear the content of the cache *)
+  let clear c =
+    c.len <- 0;
+    H.clear c.table;
+    c.first.next <- c.first;
+    c.first.prev <- c.first;
+    ()
+
+  (** Find an element, or raise Not_found *)
+  let find c x =
+    let n = H.find c.table x in
+    assert (X.equal n.key x);
+    n.value
+
+  (** Replace least recently used element of [c] by x->y *)
+  let replace c x y =
+    let n = c.first.next in
+    (* remove old element *)
+    H.remove c.table n.key;
+    (* insertion in hashtable *)
+    H.add c.table x n;
+    (* re-use the node for x,y *)
+    n.key <- x;
+    n.value <- y;
+    (* remove from front of queue *)
+    n.next.prev <- c.first;
+    c.first.next <- n.next;
+    (* insert at back of queue *)
+    let last = c.first.prev in
+    last.next <- n;
+    c.first.prev <- n;
+    n.next <- c.first;
+    n.prev <- last;
+    ()
+
+  (** Insert x->y in the cache, increasing its entry count *)
+  let insert c x y =
+    c.len <- c.len + 1;
+    let n = {
+      key = x;
+      value = y;
+      next = c.first;
+      prev = c.first.prev;
+    } in
+    (* insertion in hashtable *)
+    H.add c.table x n;
+    (* insertion at back of queue *)
+    c.first.prev.next <- n;
+    c.first.prev <- n;
+    ()
+
+  (** Try to find [f x] in the cache, otherwise compute it
+      and cache the result *)
+  let with_cache c f x =
+    try
+      find c x
+    with Not_found ->
+      let y = f x in
+      (if c.len = c.size
+        then replace c x y
+        else insert c 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
diff --git a/cache.mli b/cache.mli
index c49b905d..78f2b770 100644
--- a/cache.mli
+++ b/cache.mli
@@ -94,5 +94,9 @@ module Replacing(X : HASH) : S 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 *)
+(** {2 Hashtables with Least Recently Used eviction policy *)
+
+module LRU(X : HASH) : S with type key = X.t
+
+(* TODO LRU2 *)
 
diff --git a/tests/benchs.ml b/tests/benchs.ml
index 0abcaa2a..4cb3dbe8 100644
--- a/tests/benchs.ml
+++ b/tests/benchs.ml
@@ -8,8 +8,9 @@ module Fibo(C : Cache.S with type key = int) = struct
   let fib ~size =
     let rec fib fib' n =
       match n with
-      | 0 -> 1
+      | 0 -> 0
       | 1 -> 1
+      | 2 -> 1
       | n ->
         fib' (n-1) + fib' (n-2)
     in
@@ -17,28 +18,40 @@ module Fibo(C : Cache.S with type key = int) = struct
     cached_fib
 end
 
+module LinearIntCache = Cache.Linear(struct
+  type t = int
+  let equal i j = i = j
+end)
+
+module ReplacingIntCache = Cache.Replacing(struct
+  type t = int
+  let equal i j = i = j
+  let hash i = i
+end)
+
+module LRUIntCache = Cache.LRU(struct
+  type t = int
+  let equal i j = i = j
+  let hash i = i
+end)
+
+module DummyIntCache = Cache.Dummy(struct type t = int 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 LRUFibo= Fibo(LRUIntCache) 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])
+    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);
+      "replacing_fib", bench_fib (ReplacingFibo.fib ~size:256);
+      "LRU_fib", bench_fib (LRUFibo.fib ~size:256);
       "dummy_fib", bench_fib (DummyFibo.fib ~size:5);
     ]