Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
59 lines (51 sloc) 2.57 KB
(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)))))
Something went wrong with that request. Please try again.