/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        (declare (ignorable id))
57        (when items
58          (iter (for item in-vector (the vector items))
59                (funcall (destructor cache) item)))))