1 (defpackage :sqlite.cache
8 (in-package :sqlite.cache
)
10 ;(declaim (optimize (speed 3) (safety 0) (debug 0)))
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
)))
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
)))))
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
))
32 (remhash key
(last-access-time-table cache
))))
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
))))
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
)))
54 (defun purge-cache (cache)
55 (iter (for (id items
) in-hashtable
(objects-table cache
))
57 (iter (for item in-vector
(the vector items
))
58 (funcall (destructor cache
) item
)))))