[clouchdb-cvs] CVS clouchdb/src

[peddy]

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

Added Files:
	cache.lisp 
Log Message:
Adding cache for real this time



--- /project/clouchdb/cvsroot/clouchdb/src/cache.lisp	2008/01/07 01:23:41	NONE
+++ /project/clouchdb/cvsroot/clouchdb/src/cache.lisp	2008/01/07 01:23:41	1.1
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CLOUCHDB; Base: 10 -*-

;;; Copyright (c) 2007 Peter Eddy. All rights reserved.

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:

;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.

;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

(in-package :clouchdb)

(proclaim '(inline cache-size rmcache))

;; Representation of cached value
(defstruct cached key value previous next)

;; The cache data structure
(defstruct cache 
  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)
                      (test #'eql))
  "Make a new MRU cache."
  (make-cache :hashtable (make-hash-table :size size 
                                          :test test
                                          :rehash-size rehash-size
                                          :rehash-threshold rehash-threshold)
              :max-size max-size))

(defun remove-element (element cache)
  "Remove specified element from cache linked list"
  (if (cached-previous element)
      (setf (cached-next (cached-previous element)) (cached-next element))
      (setf (cache-head cache) (cached-next element)))
  (if (cached-next element)
      (setf (cached-previous (cached-next element)) (cached-previous element))
      (setf (cache-tail cache) (cached-previous element))))

(defun cache-size (cache)
  "Return number of elements in cache."
  (hash-table-count (cache-hashtable cache)))

(defun move-to-top (element cache)
  "Move specified cache element to top of cache"
  (unless (eq (cache-head cache) element)
    (remove-element element cache)
    (setf (cached-previous element) nil)
    (let ((old-head (cache-head cache)))
      (setf (cache-head cache) element)
      (setf (cached-next element) old-head)
      (if old-head
          (setf (cached-previous old-head) element)
          (setf (cache-tail cache) element)))))

(defun set-cache-top (element cache)
  "Set the element at the top of the cache. Used when adding new
element."
  (let ((head (cache-head cache)))
    (cond ((null head)
           (setf (cache-tail cache) element))
          (t
           (setf (cached-previous head) element)
           (setf (cached-next element) head)))
    (setf (cache-head cache) element)))

(defun get-cached (key cache)
  "Get cached value by key."
  (let ((element (gethash key (cache-hashtable cache))))
    (when element
      (move-to-top element cache)
      (cached-value element))))

(defun rmcache (element cache)
  "Remove element from hashtable and linked list."
  (remove-element element cache)
  (remhash (cached-key element) (cache-hashtable cache)))

(defun (setf get-cached) (value key cache)
  "Add new cached value or update current value associated with
key. Moves cached element to top of cache list. May result in least
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)))
          (t 
           (move-to-top element cache)
           (setf (cached-value element) value)
           (move-to-top element cache)))
    (when (> (cache-size cache)
             (cache-max-size cache))
      (rmcache (cache-tail cache) cache))
    cache))

(defun remove-cached (key cache)
  "Remove specified element from cache"
  (let ((element (gethash key (cache-hashtable cache))))
    (when element
      (rmcache element cache))))