/cache.lisp
Lisp | 59 lines | 50 code | 8 blank | 1 comment | 0 complexity | 2c8cf4645a4dc5cddb240cf59c672939 MD5 | raw file
- (defpackage :sqlite.cache
- (:use :cl :iter)
- (:export :mru-cache
- :get-from-cache
- :put-to-cache
- :purge-cache))
- (in-package :sqlite.cache)
- ;(declaim (optimize (speed 3) (safety 0) (debug 0)))
- (defclass mru-cache ()
- ((objects-table :accessor objects-table :initform (make-hash-table :test 'equal))
- (last-access-time-table :accessor last-access-time-table :initform (make-hash-table :test 'equal))
- (total-cached :type fixnum :accessor total-cached :initform 0)
- (cache-size :type fixnum :accessor cache-size :initarg :cache-size :initform 100)
- (destructor :accessor destructor :initarg :destructor :initform #'identity)))
- (defun get-from-cache (cache id)
- (let ((available-objects-stack (gethash id (objects-table cache))))
- (when (and available-objects-stack (> (length (the vector available-objects-stack)) 0))
- (decf (the fixnum (total-cached cache)))
- (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
- (vector-pop (the vector available-objects-stack)))))
- (defun remove-empty-objects-stacks (cache)
- (let ((table (objects-table cache)))
- (maphash (lambda (key value)
- (declare (type vector value))
- (when (zerop (length value))
- (remhash key table)
- (remhash key (last-access-time-table cache))))
- table)))
- (defun pop-from-cache (cache)
- (let ((id (iter (for (id time) in-hashtable (last-access-time-table cache))
- (when (not (zerop (length (the vector (gethash id (objects-table cache))))))
- (finding id minimizing (the fixnum time))))))
- (let ((object (vector-pop (gethash id (objects-table cache)))))
- (funcall (destructor cache) object)))
- (remove-empty-objects-stacks cache)
- (decf (the fixnum (total-cached cache))))
- (defun put-to-cache (cache id object)
- (when (>= (the fixnum (total-cached cache)) (the fixnum (cache-size cache)))
- (pop-from-cache cache))
- (let ((available-objects-stack (or (gethash id (objects-table cache))
- (setf (gethash id (objects-table cache)) (make-array 0 :adjustable t :fill-pointer t)))))
- (vector-push-extend object available-objects-stack)
- (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
- (incf (the fixnum (total-cached cache)))
- object))
- (defun purge-cache (cache)
- (iter (for (id items) in-hashtable (objects-table cache))
- (declare (ignorable id))
- (when items
- (iter (for item in-vector (the vector items))
- (funcall (destructor cache) item)))))