/cache.lisp
Lisp | 59 lines | 50 code | 8 blank | 1 comment | 0 complexity | 2c8cf4645a4dc5cddb240cf59c672939 MD5 | raw file
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)))))