[clouchdb-cvs] CVS clouchdb/src

[peddy]

Update of /project/clouchdb/cvsroot/clouchdb/src
In directory clnet:/tmp/cvs-serv5413

Modified Files:
	cache.lisp 
Log Message:
Fixed bug in mru cache, added tests


--- /project/clouchdb/cvsroot/clouchdb/src/cache.lisp	2008/01/07 01:23:41	1.1
+++ /project/clouchdb/cvsroot/clouchdb/src/cache.lisp	2008/01/12 20:44:41	1.2
@@ -24,9 +24,13 @@
 
 (in-package :clouchdb)
 
+;;; This is an implementation of a most recently used cache. It's
+;;; primary data structures are a hashtable and a doubly linked list
+;;; list.
+
 (proclaim '(inline cache-size rmcache))
 
-;; Representation of cached value
+;; Representation of cached value (hash table value)
 (defstruct cached key value previous next)
 
 ;; The cache data structure
@@ -34,10 +38,8 @@
   hashtable head tail 
   (max-size 300 :type integer))
 
-(defun new-mru-cache (&key (size 100) 
-                      (rehash-size 100)
-                      (rehash-threshold 0.9)
-                      (max-size 100)
+(defun make-mru-cache (&key (size 100) (rehash-size 100)
+                      (rehash-threshold 0.9) (max-size 300)
                       (test #'eql))
   "Make a new MRU cache."
   (make-cache :hashtable (make-hash-table :size size 
@@ -59,7 +61,7 @@
   "Return number of elements in cache."
   (hash-table-count (cache-hashtable cache)))
 
-(defun move-to-top (element cache)
+(defun move-to-head (element cache)
   "Move specified cache element to top of cache"
   (unless (eq (cache-head cache) element)
     (remove-element element cache)
@@ -74,9 +76,11 @@
 (defun set-cache-top (element cache)
   "Set the element at the top of the cache. Used when adding new
 element."
+  (setf (cached-previous element) nil)
   (let ((head (cache-head cache)))
     (cond ((null head)
-           (setf (cache-tail cache) element))
+           (setf (cache-tail cache) element)
+           (setf (cached-next element) nil))
           (t
            (setf (cached-previous head) element)
            (setf (cached-next element) head)))
@@ -86,7 +90,7 @@
   "Get cached value by key."
   (let ((element (gethash key (cache-hashtable cache))))
     (when element
-      (move-to-top element cache)
+      (move-to-head element cache)
       (cached-value element))))
 
 (defun rmcache (element cache)
@@ -100,20 +104,73 @@
 recently used element element being removed."
   (let ((element (gethash key (cache-hashtable cache))))
     (cond ((null element)
-           (let ((new-element (make-cached :key key :value value)))
-             (setf (gethash key (cache-hashtable cache)) new-element)
-             (set-cache-top new-element cache)))
+           (set-cache-top 
+            (setf (gethash key (cache-hashtable cache))
+                  (make-cached :key key :value value))
+            cache))
           (t 
-           (move-to-top element cache)
+           (move-to-head element cache)
            (setf (cached-value element) value)
-           (move-to-top element cache)))
+           (move-to-head element cache)))
     (when (> (cache-size cache)
              (cache-max-size cache))
       (rmcache (cache-tail cache) cache))
-    cache))
+    value))
 
 (defun remove-cached (key cache)
   "Remove specified element from cache"
   (let ((element (gethash key (cache-hashtable cache))))
     (when element
-      (rmcache element cache))))
\ No newline at end of file
+      (rmcache element cache))))
+
+;;
+;; Tests and test helper functions
+;;
+
+(defun cached-keys (cache)
+  "For testing, quick way to view keys in hashtable."
+  (let ((keys))
+    (maphash #'(lambda (k v) (push k keys)) (cache-hashtable cache))
+    keys))
+
+(defun linked-list-length (cache)
+  (labels ((lllen (ll len)
+             (if (null ll)
+                 len
+                 (lllen (cached-next ll) (1+ len)))))
+    (lllen (cache-head cache) 0)))
+
+(defun list-vals-not-in-hash (cache)
+  "Return items in the mru cache's linked list that are not in the cache."
+  (let ((res))
+    (labels ((lvnic (ll)
+               (when ll
+                 (format t "testing: ~s~%" (cached-key ll))
+                  (when (null (gethash (cached-key ll) (cache-hashtable cache)))
+                    (format t "found uncached: ~s~%" (cached-key ll))
+                    (push ll res))
+                 (lvnic (cached-next ll)))))
+      (lvnic (cache-head cache)))
+    res))
+
+(defun find-key-in-list (cache key)
+  (labels ((fkil (ll)
+             (cond ((null ll)
+                    nil)
+                   ((equal (cached-key ll) key)
+                    ll)
+                   (t (fkil (cached-next ll))))))
+    (fkil (cache-head cache))))
+
+(defun hash-keys-not-in-list (cache)
+  (let ((res))
+    (maphash #'(lambda (k v)
+                 (unless (find-key-in-list cache k)
+                   (push k res)))
+             (cache-hashtable cache))))
+
+(defun test-cache-consistency (cache)
+  (format t "Cache size: ~S, linked list length: ~S~%" 
+          (cache-size cache) (linked-list-length cache))
+  (format t "Keys not in list: ~S~%" (hash-keys-not-in-list cache))
+  (format t "List values not in hash: ~S~%" (list-vals-not-in-hash cache)))