cache.lisp

   1 (defpackage :sqlite.cache
   2   (:use :cl :iter)
   3   (:export :mru-cache
   4            :get-from-cache
   5            :put-to-cache
   6            :purge-cache))
   7
   8 (in-package :sqlite.cache)
   9
  10 ;(declaim (optimize (speed 3) (safety 0) (debug 0)))
  11
  12 (defclass mru-cache ()
  13   ((objects-table :accessor objects-table :initform (make-hash-table :test 'equal))
  14    (last-access-time-table :accessor last-access-time-table :initform (make-hash-table :test 'equal))
  15    (total-cached :type fixnum :accessor total-cached :initform 0)
  16    (cache-size :type fixnum :accessor cache-size :initarg :cache-size :initform 100)
  17    (destructor :accessor destructor :initarg :destructor :initform #'identity)))
  18
  19 (defun get-from-cache (cache id)
  20   (let ((available-objects-stack (gethash id (objects-table cache))))
  21     (when (and available-objects-stack (> (length (the vector available-objects-stack)) 0))
  22       (decf (the fixnum (total-cached cache)))
  23       (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
  24       (vector-pop (the vector available-objects-stack)))))
  25
  26 (defun remove-empty-objects-stacks (cache)
  27   (let ((table (objects-table cache)))
  28    (maphash (lambda (key value)
  29               (declare (type vector value))
  30               (when (zerop (length value))
  31                 (remhash key table)
  32                 (remhash key (last-access-time-table cache))))
  33             table)))
  34
  35 (defun pop-from-cache (cache)
  36   (let ((id (iter (for (id time) in-hashtable (last-access-time-table cache))
  37                   (when (not (zerop (length (the vector (gethash id (objects-table cache))))))
  38                     (finding id minimizing (the fixnum time))))))
  39     (let ((object (vector-pop (gethash id (objects-table cache)))))
  40       (funcall (destructor cache) object)))
  41   (remove-empty-objects-stacks cache)
  42   (decf (the fixnum (total-cached cache))))
  43
  44 (defun put-to-cache (cache id object)
  45   (when (>= (the fixnum (total-cached cache)) (the fixnum (cache-size cache)))
  46     (pop-from-cache cache))
  47   (let ((available-objects-stack (or (gethash id (objects-table cache))
  48                                       (setf (gethash id (objects-table cache)) (make-array 0 :adjustable t :fill-pointer t)))))
  49     (vector-push-extend object available-objects-stack)
  50     (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
  51     (incf (the fixnum (total-cached cache)))
  52     object))
  53
  54 (defun purge-cache (cache)
  55   (iter (for (id items) in-hashtable (objects-table cache))
  56         (when items
  57           (iter (for item in-vector (the vector items))
  58                 (funcall (destructor cache) item)))))