├── src ├── policy.lisp ├── package.lisp ├── entry.lisp ├── testsuite.lisp ├── lfu-policies.lisp ├── simple-policies.lisp └── cache.lisp ├── cacle.asd ├── LICENSE └── README.md /src/policy.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cacle) 2 | 3 | (defclass replacement-policy () 4 | ()) 5 | 6 | (defgeneric entry-added (policy entry)) 7 | (defgeneric access-entry (policy entry)) 8 | (defgeneric entry-removed (policy entry)) 9 | (defgeneric evict-entry (policy size-hint)) 10 | 11 | #+5am 12 | (defgeneric list-entries (policy)) 13 | -------------------------------------------------------------------------------- /cacle.asd: -------------------------------------------------------------------------------- 1 | (in-package #:cl) 2 | (defpackage #:cacle-system (:use #:asdf #:cl)) 3 | (in-package #:cacle-system) 4 | 5 | (asdf:defsystem cacle 6 | :name "cacle" 7 | :version "1.0.1" 8 | :author "Jussi Lahdenniemi " 9 | :maintainer "Jussi Lahdenniemi " 10 | :license "MIT" 11 | :description "Extensible cache services for Common Lisp" 12 | :encoding :utf-8 13 | :depends-on (bordeaux-threads) 14 | :components 15 | ((:module cacle 16 | :pathname "src" 17 | :components ((:file "package") 18 | (:file "testsuite" :depends-on ("package")) 19 | (:file "entry" :depends-on ("package" "testsuite")) 20 | (:file "policy" :depends-on ("entry")) 21 | (:file "simple-policies" :depends-on ("policy")) 22 | (:file "lfu-policies" :depends-on ("policy")) 23 | (:file "cache" :depends-on ("entry" "simple-policies")))))) 24 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :cacle 2 | (:use #:cl) 3 | (:export 4 | #:cache #:cache-max-size #:cache-provider #:cache-cleanup #:cache-lifetime #:cache-policy 5 | #:cache-size #:cache-count 6 | #:make-cache #:cache-fetch #:cache-release #:with-cache-fetch #:cache-remove #:cache-flush 7 | #:cache-entry #:entry-key #:entry-valid-p #:entry-size #:entry-expiry 8 | #:linked-cache-entry #:entry-next #:entry-previous #:unlink #:link-before #:link-after 9 | #:indexed-cache-entry #:entry-index 10 | #:replacement-policy #:entry-added #:access-entry #:entry-removed #:evict-entry 11 | #:linked-list-replacement-policy #:linked-list-head 12 | #:fifo-replacement-policy #:lifo-replacement-policy 13 | #:lru-replacement-policy #:mru-replacement-policy 14 | #:random-replacement-policy 15 | #:lfu-replacement-policy #:lfuda-replacement-policy 16 | #:cacle-tests)) 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2017 Jussi Lahdenniemi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /src/entry.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cacle) 2 | 3 | #+5am 4 | (5am:in-suite cacle-tests) 5 | 6 | (defclass cache-entry () 7 | ((key :initarg :key :reader entry-key) 8 | (data) 9 | (pending :initarg :pending) 10 | (busy :initform 0 :accessor entry-busy) 11 | (size :reader entry-size) 12 | (expiry :reader entry-expiry))) 13 | 14 | (defmethod print-object ((obj cache-entry) stream) 15 | (print-unreadable-object (obj stream :type t :identity t) 16 | (princ "key " stream) 17 | (prin1 (slot-value obj 'key) stream))) 18 | 19 | (defmethod entry-valid-p ((entry cache-entry)) 20 | (slot-boundp entry 'size)) 21 | 22 | (defclass linked-cache-entry (cache-entry) 23 | ((next :reader entry-next) 24 | (prev :reader entry-previous))) 25 | 26 | (defmethod shared-initialize ((entry linked-cache-entry) slot-names &rest initargs) 27 | (declare (ignore initargs)) 28 | (call-next-method) 29 | (when (or (eq slot-names t) 30 | (find 'next slot-names)) 31 | (setf (slot-value entry 'next) entry)) 32 | (when (or (eq slot-names t) 33 | (find 'prev slot-names)) 34 | (setf (slot-value entry 'prev) entry))) 35 | 36 | (defmethod unlink ((entry linked-cache-entry)) 37 | (let ((n (slot-value entry 'next)) 38 | (p (slot-value entry 'prev))) 39 | (when (and (eq n entry) 40 | (eq p entry)) 41 | (error "Attempt to unlink an already unlinked entry ~s" entry)) 42 | (setf (slot-value n 'prev) p 43 | (slot-value p 'next) n 44 | (slot-value entry 'next) entry 45 | (slot-value entry 'prev) entry) 46 | entry)) 47 | 48 | (defun ensure-unlinked (entry) 49 | (with-slots (next prev) 50 | entry 51 | (unless (and (eq next entry) 52 | (eq prev entry)) 53 | (error "Attempt to link an already linked entry ~s" entry)))) 54 | 55 | (defmethod link-before ((entry linked-cache-entry) (ref linked-cache-entry)) 56 | (ensure-unlinked entry) 57 | (let ((n ref) 58 | (p (slot-value ref 'prev))) 59 | (setf (slot-value p 'next) entry 60 | (slot-value n 'prev) entry 61 | (slot-value entry 'next) n 62 | (slot-value entry 'prev) p) 63 | entry)) 64 | 65 | (defmethod link-after ((entry linked-cache-entry) (ref linked-cache-entry)) 66 | (ensure-unlinked entry) 67 | (let ((n (slot-value ref 'next)) 68 | (p ref)) 69 | (setf (slot-value p 'next) entry 70 | (slot-value n 'prev) entry 71 | (slot-value entry 'next) n 72 | (slot-value entry 'prev) p) 73 | entry)) 74 | 75 | #+5am 76 | (5am:test linked-entries 77 | (let ((head (make-instance 'linked-cache-entry)) 78 | (e1 (make-instance 'linked-cache-entry)) 79 | (e2 (make-instance 'linked-cache-entry))) 80 | (flet ((ensure-order (&rest list) 81 | (loop for i on list 82 | for a = (first i) 83 | for b = (or (second i) (first list)) 84 | do (5am:is (entry-next a) b) 85 | do (5am:is (entry-previous b) a)))) 86 | (ensure-order head) 87 | (link-after e1 head) 88 | (ensure-order head e1) 89 | (link-after e2 head) 90 | (ensure-order head e2 e1) 91 | (unlink e2) 92 | (ensure-order head e1) 93 | (ensure-order e2) 94 | (link-before e2 head) 95 | (ensure-order head e1 e2)))) 96 | 97 | (defclass indexed-cache-entry (cache-entry) 98 | ((index :accessor entry-index))) 99 | -------------------------------------------------------------------------------- /src/testsuite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cacle) 2 | 3 | #+5am 4 | (5am:def-suite cacle-tests :description "cacle test suite") 5 | 6 | #+5am 7 | (5am:in-suite cacle-tests) 8 | 9 | #+5am 10 | (defmacro with-testing-cache ((var size &key policy lifetime item-size-modulus without-cleanup (cleanup-checks t)) &body body) 11 | (let ((provider (gensym)) 12 | (cleanup (gensym)) 13 | (object (gensym)) 14 | (lock (gensym)) 15 | (arg (gensym))) 16 | `(let ((,object 0) 17 | (,lock (bt:make-lock "mutex for with-testing-cache"))) 18 | (flet ((,provider (,arg) 19 | (bt:with-lock-held (,lock) 20 | (values (list ,arg (incf ,object)) ,(if item-size-modulus 21 | `(mod ,arg ,item-size-modulus) 22 | arg)))) 23 | ,@(and (not without-cleanup) 24 | `((,cleanup (,arg) 25 | ,@(when cleanup-checks 26 | `((5am:is (listp ,arg)) 27 | (5am:is (= 2 (length ,arg))))) 28 | (setf (cdr ,arg) (list :cleaned-up (second ,arg)))) 29 | (fetch-and-release (cache key) 30 | (multiple-value-bind (item tag) 31 | (cache-fetch cache key) 32 | (cache-release cache tag) 33 | item)) 34 | (cleaned-up-p (,arg) 35 | (cond ((eq (second ,arg) :cleaned-up) 36 | t) 37 | ((integerp (second ,arg)) 38 | nil) 39 | (t 40 | (error "Corrupted cache data ~s" ,arg))))))) 41 | (let ((,var (make-cache ,size #',provider 42 | :policy (or ,policy :fifo) 43 | ,@(and (not without-cleanup) 44 | `(:cleanup #',cleanup)) 45 | ,@(and lifetime 46 | `(:lifetime ,lifetime))))) 47 | ,@body))))) 48 | 49 | #+5am 50 | (5am:test bélády-replacement-policy 51 | (5am:signals error (make-cache 100 #'list :policy :bélády))) 52 | 53 | #+5am 54 | (5am:test random-single-thread-testing 55 | (let ((repetitions 100000)) 56 | (dolist (policy '(:fifo :lifo :lru :mru :random :lfu :lfuda)) 57 | (with-testing-cache (cache 1000 :policy policy :cleanup-checks nil) 58 | (dotimes (i repetitions) 59 | (let* ((key (1+ (random 100)))) 60 | (multiple-value-bind (data tag) 61 | (cache-fetch cache key) 62 | (unless (= (first data) key) 63 | (5am:fail "attempt to fetch data for key ~a resulted in ~s" key data)) 64 | (cache-release cache tag)))) 65 | (5am:is (> (cache-size cache) 900)) 66 | (5am:is (> (cache-count cache) 10)) 67 | (handler-case 68 | (cache-sanity-check cache) 69 | (error (e) 70 | (error "With policy ~a: ~a" policy e))))))) 71 | 72 | #+5am 73 | (5am:test random-multi-thread-testing 74 | (let ((threads 4) 75 | (repetitions 25000)) 76 | (dolist (policy '(:fifo :lifo :lru :mru :random :lfu :lfuda)) 77 | (with-testing-cache (cache 1000 :policy policy :cleanup-checks nil) 78 | (let* ((out *standard-output*) 79 | (threads (loop for i below threads 80 | collect (bt:make-thread 81 | #'(lambda () 82 | (let ((ok t)) 83 | (dotimes (i repetitions) 84 | (let* ((key (1+ (random 100)))) 85 | (multiple-value-bind (data tag) 86 | (cache-fetch cache key) 87 | (unless (and (= (first data) key) 88 | (not (cleaned-up-p data))) 89 | (setf ok nil) 90 | (format out "~%attempt to fetch data for key ~a resulted in ~s" key data) 91 | (return)) 92 | (cache-release cache tag)))) 93 | ok)))))) 94 | (5am:is (zerop (count-if-not #'identity (mapcar #'bt:join-thread threads))))) 95 | (5am:is (> (cache-size cache) 900)) 96 | (5am:is (> (cache-count cache) 10)) 97 | (handler-case 98 | (cache-sanity-check cache) 99 | (error (e) 100 | (error "With policy ~a: ~a" policy e))))))) 101 | -------------------------------------------------------------------------------- /src/lfu-policies.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cacle) 2 | 3 | #+5am 4 | (5am:in-suite cacle-tests) 5 | 6 | ;;; Heap structure for LFU policies 7 | 8 | (defclass heap-cache-entry (indexed-cache-entry) 9 | ((weight :accessor cache-entry-weight))) 10 | 11 | (defmethod print-object ((obj heap-cache-entry) stream) 12 | (print-unreadable-object (obj stream :type t :identity t) 13 | (princ "key " stream) 14 | (prin1 (slot-value obj 'key) stream) 15 | (princ " weight " stream) 16 | (prin1 (slot-value obj 'weight) stream))) 17 | 18 | (defun heap-parent-idx (idx) 19 | (floor (1- idx) 2)) 20 | 21 | (defun heap-left-idx (idx) 22 | (1+ (* idx 2))) 23 | 24 | (defun heap-right-idx (idx) 25 | (* (1+ idx) 2)) 26 | 27 | (defun heap-parent (heap idx) 28 | (and (> idx 0) 29 | (aref heap (heap-parent-idx idx)))) 30 | 31 | (defun heap-left (heap idx) 32 | (let ((left (heap-left-idx idx))) 33 | (and (< left (length heap)) 34 | (aref heap left)))) 35 | 36 | (defun heap-right (heap idx) 37 | (let ((right (heap-right-idx idx))) 38 | (and (< right (length heap)) 39 | (aref heap right)))) 40 | 41 | (defun heap-swap (heap i1 i2) 42 | (let ((e1 (aref heap i1)) 43 | (e2 (aref heap i2))) 44 | (setf (entry-index e1) i2 45 | (entry-index e2) i1 46 | (aref heap i1) e2 47 | (aref heap i2) e1) 48 | (values e2 e1))) 49 | 50 | (defun sink-down (heap idx &optional prefer-to-sink) 51 | (let ((me (aref heap idx)) 52 | (left (heap-left heap idx)) 53 | (right (heap-right heap idx))) 54 | (unless (and (or (null left) 55 | (< (cache-entry-weight me) 56 | (cache-entry-weight left)) 57 | (and (not prefer-to-sink) 58 | (= (cache-entry-weight me) 59 | (cache-entry-weight left)))) 60 | (or (null right) 61 | (< (cache-entry-weight me) 62 | (cache-entry-weight right)) 63 | (and (not prefer-to-sink) 64 | (= (cache-entry-weight me) 65 | (cache-entry-weight right))))) 66 | ;; heavier than (one of) children, do sink 67 | (let ((lightest (if (and right 68 | (< (cache-entry-weight right) 69 | (cache-entry-weight left))) 70 | (heap-right-idx idx) 71 | (heap-left-idx idx)))) 72 | (heap-swap heap idx lightest) 73 | (sink-down heap lightest prefer-to-sink))))) 74 | 75 | (defun bubble-up (heap idx) 76 | (let ((me (aref heap idx)) 77 | (parent (heap-parent heap idx))) 78 | (unless (or (null parent) 79 | (>= (cache-entry-weight me) 80 | (cache-entry-weight parent))) 81 | ;; lighter than parent, do bubble 82 | (let ((p (heap-parent-idx idx))) 83 | (heap-swap heap idx p) 84 | (bubble-up heap p))))) 85 | 86 | ;;; Discard the Least Frequenty Used entry 87 | 88 | (defclass lfu-replacement-policy (replacement-policy) 89 | ((heap :initform (make-array 16 :adjustable t :fill-pointer 0)))) 90 | 91 | (defmethod entry-added ((policy lfu-replacement-policy) (entry cache-entry)) 92 | (change-class entry 'heap-cache-entry) 93 | (with-slots (heap) policy 94 | (setf (cache-entry-weight entry) 1 95 | (entry-index entry) (vector-push-extend entry heap)) 96 | (bubble-up heap (entry-index entry)))) 97 | 98 | (defmethod access-entry ((policy lfu-replacement-policy) (entry heap-cache-entry)) 99 | (incf (cache-entry-weight entry)) 100 | (sink-down (slot-value policy 'heap) (entry-index entry) t) 101 | t) 102 | 103 | (defmethod entry-removed ((policy lfu-replacement-policy) (entry heap-cache-entry)) 104 | (with-slots (heap) policy 105 | (let ((i (entry-index entry))) 106 | (setf (entry-index entry) nil) 107 | (unless (= i (1- (length heap))) 108 | (setf (aref heap i) (vector-pop heap) 109 | (entry-index (aref heap i)) i) 110 | (sink-down heap i))))) 111 | 112 | (defmethod evict-entry ((policy lfu-replacement-policy) size-hint) 113 | (declare (ignore size-hint)) 114 | (with-slots (heap) policy 115 | (when (> (length heap) 0) 116 | (let* ((lightest (aref heap 0)) 117 | (heaviest (vector-pop heap))) 118 | (when (> (length heap) 0) 119 | (setf (aref heap 0) heaviest 120 | (entry-index heaviest) 0) 121 | (sink-down heap 0 t)) 122 | lightest)))) 123 | 124 | #+5am 125 | (defmethod list-entries ((policy lfu-replacement-policy)) 126 | (coerce (slot-value policy 'heap) 'list)) 127 | 128 | #+5am 129 | (5am:test lfu-replacement-policy 130 | (with-testing-cache (cache 100 :policy :lfu) 131 | (let* ((a (fetch-and-release cache 21)) 132 | (b (fetch-and-release cache 22)) 133 | (c (fetch-and-release cache 23)) 134 | (d (fetch-and-release cache 24))) 135 | (5am:is (= 0 (count-if #'cleaned-up-p (list a b c d)))) 136 | (fetch-and-release cache 21) 137 | (fetch-and-release cache 23) 138 | (fetch-and-release cache 24) 139 | (fetch-and-release cache 23) 140 | (fetch-and-release cache 21) 141 | (let ((e (fetch-and-release cache 25))) 142 | (5am:is (cleaned-up-p b)) 143 | (fetch-and-release cache 26) 144 | (5am:is (cleaned-up-p e)) 145 | (cache-sanity-check cache))))) 146 | 147 | ;;; Discard the Least Frequently Used entry (with dynamic aging) 148 | 149 | (defclass lfuda-replacement-policy (lfu-replacement-policy) 150 | ((age :initform 0))) 151 | 152 | (defmethod entry-added ((policy lfuda-replacement-policy) (entry cache-entry)) 153 | (call-next-method) 154 | (incf (cache-entry-weight entry) (slot-value policy 'age)) 155 | (sink-down (slot-value policy 'heap) (entry-index entry))) 156 | 157 | (defmethod evict-entry ((policy lfuda-replacement-policy) size-hint) 158 | (declare (ignore size-hint)) 159 | (let ((target (call-next-method))) 160 | (when target 161 | (setf (slot-value policy 'age) (cache-entry-weight target))) 162 | target)) 163 | 164 | #+5am 165 | (5am:test lfuda-replacement-policy 166 | (with-testing-cache (cache 100 :policy :lfuda :item-size-modulus 100) 167 | (let* ((a (fetch-and-release cache 125)) 168 | (b (fetch-and-release cache 225)) 169 | (c (fetch-and-release cache 325)) 170 | (d (fetch-and-release cache 425))) 171 | (dotimes (i 40) 172 | (5am:is (eq a (fetch-and-release cache 125))) 173 | (when (>= i 10) 174 | (5am:is (eq d (fetch-and-release cache 425)))) 175 | (when (>= i 20) 176 | (5am:is (eq b (fetch-and-release cache 225)))) 177 | (when (>= i 30) 178 | (5am:is (eq c (fetch-and-release cache 325))))) 179 | (dotimes (i 5) 180 | (let ((e (fetch-and-release cache 525))) 181 | (5am:is (cleaned-up-p c)) 182 | (setf c (fetch-and-release cache 625)) 183 | (5am:is (cleaned-up-p e)))) 184 | (dotimes (i 100) 185 | (fetch-and-release cache 525) 186 | (fetch-and-release cache 625) 187 | (fetch-and-release cache 725) 188 | (fetch-and-release cache 825)) 189 | (5am:is (= 0 (count-if-not #'cleaned-up-p (list a b d)))) 190 | (cache-sanity-check cache)))) 191 | 192 | -------------------------------------------------------------------------------- /src/simple-policies.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cacle) 2 | 3 | #+5am 4 | (5am:in-suite cacle-tests) 5 | 6 | ;;; Generic base for caching policies that store entries in a linked list 7 | 8 | (defclass linked-list-replacement-policy (replacement-policy) 9 | ((head :initform (make-instance 'linked-cache-entry) :reader linked-list-head))) 10 | 11 | (defmethod print-object ((obj linked-list-replacement-policy) stream) 12 | (print-unreadable-object (obj stream :type t :identity t) 13 | (loop with head = (slot-value obj 'head) 14 | for i = (slot-value head 'next) then (slot-value i 'next) 15 | until (eq i head) 16 | do (format stream " ~a" (slot-value i 'key))))) 17 | 18 | (defmethod entry-added :before ((policy linked-list-replacement-policy) (entry cache-entry)) 19 | (change-class entry 'linked-cache-entry)) 20 | 21 | (defmethod access-entry ((policy linked-list-replacement-policy) (entry linked-cache-entry)) 22 | ;; No time-based validation 23 | t) 24 | 25 | (defmethod entry-added ((policy linked-list-replacement-policy) (entry cache-entry)) 26 | ;; Push to head of the queue 27 | (link-after entry (slot-value policy 'head))) 28 | 29 | (defmethod entry-removed ((policy linked-list-replacement-policy) (entry linked-cache-entry)) 30 | (unlink entry)) 31 | 32 | #+5am 33 | (defmethod list-entries ((policy linked-list-replacement-policy)) 34 | (loop with head = (slot-value policy 'head) 35 | for i = (slot-value head 'next) then (slot-value i 'next) 36 | until (eq i head) 37 | collect i)) 38 | 39 | ;;; Generic base for caching policies that store entries in an array 40 | 41 | (defclass array-replacement-policy (replacement-policy) 42 | ((data :initform (make-array 16 :adjustable t :fill-pointer 0)) 43 | (unused :initform (make-array 16 :adjustable t :fill-pointer 0)))) 44 | 45 | (defmethod entry-added :before ((policy array-replacement-policy) (entry cache-entry)) 46 | (change-class entry 'indexed-cache-entry)) 47 | 48 | (defmethod access-entry ((policy array-replacement-policy) (entry cache-entry)) 49 | t) 50 | 51 | (defmethod entry-added ((policy array-replacement-policy) (entry cache-entry)) 52 | (with-slots (data unused) policy 53 | (if (zerop (length unused)) 54 | (setf (entry-index entry) (vector-push-extend entry data)) 55 | (let ((i (vector-pop unused))) 56 | (setf (entry-index entry) i 57 | (aref data i) entry))))) 58 | 59 | (defmethod entry-removed ((policy array-replacement-policy) (entry indexed-cache-entry)) 60 | (with-slots (data unused) policy 61 | (let ((i (entry-index entry))) 62 | (vector-push-extend i unused) 63 | (setf (aref data i) nil 64 | (entry-index entry) nil) 65 | (when (> (length unused) (/ (length data) 4)) 66 | (let ((w 0)) 67 | (loop for i below (length data) 68 | for e = (aref data i) 69 | when e 70 | do (if (= w i) 71 | (incf w) 72 | (setf (entry-index e) w 73 | (aref data w) e 74 | w (1+ w)))) 75 | (setf (fill-pointer data) w 76 | (fill-pointer unused) 0)))))) 77 | 78 | #+5am 79 | (defmethod list-entries ((policy array-replacement-policy)) 80 | (loop for i across (slot-value policy 'data) 81 | when i collect i)) 82 | 83 | ;;; FIFO: Always discard the oldest entry 84 | 85 | (defclass fifo-replacement-policy (linked-list-replacement-policy) 86 | ()) 87 | 88 | (defmethod evict-entry ((policy fifo-replacement-policy) size-hint) 89 | (declare (ignore size-hint)) 90 | (with-slots (head) policy 91 | (let ((last (slot-value head 'prev))) 92 | (unless (eq last head) 93 | (unlink last) 94 | last)))) 95 | 96 | #+5am 97 | (5am:test fifo-replacement-policy 98 | (with-testing-cache (cache 100 :policy :fifo) 99 | (let* ((a (fetch-and-release cache 20)) 100 | (b (fetch-and-release cache 30)) 101 | (c (fetch-and-release cache 40)) 102 | (d (fetch-and-release cache 25))) 103 | (5am:is (cleaned-up-p a)) 104 | (5am:is (not (cleaned-up-p b))) 105 | (5am:is (not (cleaned-up-p c))) 106 | (5am:is (eq d (fetch-and-release cache 25))) 107 | (5am:is (eq c (fetch-and-release cache 40))) 108 | (5am:is (eq b (fetch-and-release cache 30))) 109 | (fetch-and-release cache 35) 110 | (5am:is (cleaned-up-p b)) 111 | (5am:is (not (cleaned-up-p c))) 112 | (5am:is (not (cleaned-up-p d))) 113 | (cache-sanity-check cache)))) 114 | 115 | ;;; LIFO: Always discard the latest entry 116 | 117 | (defclass lifo-replacement-policy (linked-list-replacement-policy) 118 | ()) 119 | 120 | (defmethod evict-entry ((policy lifo-replacement-policy) size-hint) 121 | (declare (ignore size-hint)) 122 | (with-slots (head) policy 123 | (let ((first (slot-value head 'next))) 124 | (unless (eq first head) 125 | (unlink first) 126 | first)))) 127 | 128 | #+5am 129 | (5am:test lifo-replacement-policy 130 | (with-testing-cache (cache 100 :policy :lifo) 131 | (let* ((a (fetch-and-release cache 20)) 132 | (b (fetch-and-release cache 30)) 133 | (c (fetch-and-release cache 40)) 134 | (d (fetch-and-release cache 25))) 135 | (5am:is (cleaned-up-p c)) 136 | (5am:is (not (cleaned-up-p b))) 137 | (5am:is (not (cleaned-up-p a))) 138 | (5am:is (eq a (fetch-and-release cache 20))) 139 | (5am:is (eq b (fetch-and-release cache 30))) 140 | (5am:is (eq d (fetch-and-release cache 25))) 141 | (fetch-and-release cache 35) 142 | (5am:is (cleaned-up-p d)) 143 | (cache-sanity-check cache)))) 144 | 145 | ;;; LRU: Discard the Least Recently Used entry 146 | 147 | (defclass lru-replacement-policy (fifo-replacement-policy) 148 | ()) 149 | 150 | (defmethod access-entry ((policy lru-replacement-policy) (entry cache-entry)) 151 | (unlink entry) 152 | (link-after entry (slot-value policy 'head)) 153 | t) 154 | 155 | #+5am 156 | (5am:test lru-replacement-policy 157 | (with-testing-cache (cache 100 :policy :lru) 158 | (let* ((a (fetch-and-release cache 20)) 159 | (b (fetch-and-release cache 30)) 160 | (c (fetch-and-release cache 40)) 161 | (d (fetch-and-release cache 25))) 162 | (5am:is (cleaned-up-p a)) 163 | (5am:is (not (cleaned-up-p b))) 164 | (5am:is (not (cleaned-up-p c))) 165 | (5am:is (eq d (fetch-and-release cache 25))) 166 | (5am:is (eq c (fetch-and-release cache 40))) 167 | (5am:is (eq b (fetch-and-release cache 30))) 168 | (fetch-and-release cache 22) 169 | (5am:is (cleaned-up-p d)) 170 | (5am:is (not (cleaned-up-p c))) 171 | (5am:is (not (cleaned-up-p b))) 172 | (cache-sanity-check cache)))) 173 | 174 | ;;; MRU: Discard the Most Recently Used entry 175 | 176 | (defclass mru-replacement-policy (lifo-replacement-policy) 177 | ()) 178 | 179 | (defmethod access-entry ((policy mru-replacement-policy) (entry cache-entry)) 180 | (unlink entry) 181 | (link-after entry (slot-value policy 'head)) 182 | t) 183 | 184 | #+5am 185 | (5am:test mru-replacement-policy 186 | (with-testing-cache (cache 100 :policy :mru) 187 | (let* ((a (fetch-and-release cache 20)) 188 | (b (fetch-and-release cache 30)) 189 | (c (fetch-and-release cache 40)) 190 | (d (fetch-and-release cache 25))) 191 | (5am:is (cleaned-up-p c)) 192 | (5am:is (not (cleaned-up-p b))) 193 | (5am:is (not (cleaned-up-p a))) 194 | (5am:is (eq a (fetch-and-release cache 20))) 195 | (5am:is (eq d (fetch-and-release cache 25))) 196 | (5am:is (eq b (fetch-and-release cache 30))) 197 | (fetch-and-release cache 35) 198 | (5am:is (cleaned-up-p b)) 199 | (cache-sanity-check cache)))) 200 | 201 | ;;; Random: Randomly discard one of the cached items 202 | 203 | (defclass random-replacement-policy (array-replacement-policy) 204 | ()) 205 | 206 | (defmethod evict-entry ((policy random-replacement-policy) size-hint) 207 | (declare (ignore size-hint)) 208 | (with-slots (data unused) policy 209 | (when (> (- (length data) (length unused)) 0) 210 | (let ((e (loop for i = (random (length data)) 211 | for e = (aref data i) 212 | while (null e) 213 | finally (return e)))) 214 | (entry-removed policy e) 215 | e)))) 216 | 217 | #+5am 218 | (5am:test random-replacement-policy 219 | (with-testing-cache (cache 100 :policy :fifo) 220 | (let* ((a (fetch-and-release cache 21)) 221 | (b (fetch-and-release cache 22)) 222 | (c (fetch-and-release cache 23)) 223 | (d (fetch-and-release cache 24))) 224 | (fetch-and-release cache 25) 225 | (5am:is (= (count-if #'cleaned-up-p (list a b c d)) 1)) 226 | (cache-sanity-check cache)))) 227 | -------------------------------------------------------------------------------- /src/cache.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cacle) 2 | 3 | #+5am 4 | (5am:in-suite cacle-tests) 5 | 6 | (defclass cache () 7 | ((max-size :initarg :max-size :reader cache-max-size) 8 | (size :initform 0) 9 | (lock :initform (bt:make-lock "cache")) 10 | (hash) 11 | (provider :initarg :provider :reader cache-provider) 12 | (cleanup :initarg :cleanup :initform nil :reader cache-cleanup) 13 | (lifetime :initarg :lifetime :initform nil :reader cache-lifetime) 14 | (policy :initform :fifo :initarg :policy :reader cache-policy))) 15 | 16 | (defmethod print-object ((obj cache) stream) 17 | (print-unreadable-object (obj stream :type t :identity t) 18 | (bt:with-lock-held ((slot-value obj 'lock)) 19 | (princ "count " stream) 20 | (princ (hash-table-count (slot-value obj 'hash)) stream) 21 | (princ " size " stream) 22 | (princ (slot-value obj 'size) stream) 23 | (princ "/" stream) 24 | (prin1 (cache-max-size obj) stream)))) 25 | 26 | (defmethod initialize-instance ((cache cache) &rest initargs &key policy provider (hash-test 'eql) &allow-other-keys) 27 | (declare (ignore initargs)) 28 | (call-next-method) 29 | (unless provider 30 | (error ":provider must be defined")) 31 | (setf (slot-value cache 'hash) (make-hash-table :test hash-test)) 32 | (cond ((and policy (null (cache-max-size cache))) 33 | (error "Policy defined, but no maximum size")) 34 | ((null policy) 35 | (unless (null (cache-max-size cache)) 36 | (error "Maximum size defined, but policy missing"))) 37 | ((typep policy 'replacement-policy) 38 | (setf (slot-value cache 'policy) policy)) 39 | (t 40 | (error "Invalid policy ~s" policy)))) 41 | 42 | (defun make-cache (max-size provider &key (test 'eql) (policy :fifo) lifetime cleanup) 43 | "Create a new cache with the specified maximum size, provider function, and options." 44 | (when (or (keywordp policy) 45 | (and (listp policy) 46 | (keywordp (first policy)))) 47 | (let ((base-type (if (keywordp policy) policy (first policy))) 48 | (args (if (keywordp policy) nil (rest policy)))) 49 | (setf policy (apply #'make-instance 50 | (ecase base-type 51 | (:bélády (error "Clairvoyance hardware not installed")) 52 | (:fifo 'fifo-replacement-policy) 53 | (:lifo 'lifo-replacement-policy) 54 | (:lru 'lru-replacement-policy) 55 | (:mru 'mru-replacement-policy) 56 | (:random 'random-replacement-policy) 57 | (:lfu 'lfu-replacement-policy) 58 | (:lfuda 'lfuda-replacement-policy)) 59 | args)))) 60 | (make-instance 'cache 61 | :hash-test test 62 | :max-size max-size 63 | :provider provider 64 | :policy policy 65 | :lifetime lifetime 66 | :cleanup cleanup)) 67 | 68 | (defvar *cleanup-list*) 69 | (defmacro with-collected-cleanups ((cache) &body body) 70 | (let ((i (gensym)) 71 | (fn (gensym))) 72 | `(let* ((,fn (bt:with-lock-held ((slot-value ,cache 'lock)) 73 | (slot-value ,cache 'cleanup))) 74 | (*cleanup-list* (null ,fn))) 75 | (unwind-protect 76 | (progn ,@body) 77 | (when ,fn 78 | (dolist (,i *cleanup-list*) 79 | (funcall ,fn ,i))))))) 80 | 81 | (defun prepare-cleanup (entry hash) 82 | (cond ((eq *cleanup-list* t) 83 | (remhash (entry-key entry) hash)) 84 | ((zerop (entry-busy entry)) 85 | (remhash (entry-key entry) hash) 86 | (push (slot-value entry 'data) *cleanup-list*)) 87 | ((< (entry-busy entry) 0) 88 | (error "Internal error: double prepare-cleanup for ~s" entry)) 89 | (t 90 | (setf (entry-busy entry) (- (entry-busy entry)))))) 91 | 92 | (defun ensure-cache-size (cache) 93 | (with-slots (policy hash max-size size) cache 94 | (loop while (> size max-size) 95 | for old = (evict-entry policy (- max-size size)) 96 | while old 97 | do (progn 98 | (decf size (slot-value old 'size)) 99 | (prepare-cleanup old hash))))) 100 | 101 | (defmethod cache-size ((cache cache)) 102 | "Returns the current size of the cache." 103 | (bt:with-lock-held ((slot-value cache 'lock)) 104 | (slot-value cache 'size))) 105 | 106 | (defmethod cache-count ((cache cache)) 107 | "Returns the current count of items in the cache." 108 | (bt:with-lock-held ((slot-value cache 'lock)) 109 | (hash-table-count (slot-value cache 'hash)))) 110 | 111 | (defmethod set-cache-max-size ((cache cache) new-max) 112 | (with-slots (lock max-size policy) cache 113 | (with-collected-cleanups (cache) 114 | (bt:with-lock-held (lock) 115 | (setf max-size new-max) 116 | (when policy 117 | (ensure-cache-size cache)))))) 118 | 119 | (defsetf cache-max-size set-cache-max-size) 120 | 121 | (defmethod set-cache-provider ((cache cache) new-provider) 122 | (with-slots (lock provider) cache 123 | (bt:with-lock-held (lock) 124 | (setf provider new-provider)))) 125 | 126 | (defsetf cache-provider set-cache-provider) 127 | 128 | (defmethod set-cache-cleanup ((cache cache) new-cleanup) 129 | (with-slots (lock cleanup) cache 130 | (bt:with-lock-held (lock) 131 | (setf cleanup new-cleanup)))) 132 | 133 | (defsetf cache-cleanup set-cache-cleanup) 134 | 135 | (defmethod set-cache-lifetime ((cache cache) new-lifetime) 136 | (with-slots (lock lifetime) cache 137 | (bt:with-lock-held (lock) 138 | (setf lifetime new-lifetime)))) 139 | 140 | (defsetf cache-lifetime set-cache-lifetime) 141 | 142 | (defmethod cache-fetch ((cache cache) key &key only-if-cached force-fetch) 143 | "Fetch an item for the given key. 144 | If the item is not currently in the cache, or has expired, it is fetched from the provider and stored in the cache. 145 | If force-fetch is specified, a new value is fetched from the provider even if it already exists in the cache. 146 | If a cleanup function is defined for the cache, remember to call cache-release with the second value returned by cache-fetch!" 147 | (with-slots (lock hash policy provider) cache 148 | (with-collected-cleanups (cache) 149 | (multiple-value-bind (hit data entry) 150 | (bt:with-lock-held (lock) 151 | (when force-fetch 152 | (let ((entry (gethash key hash))) 153 | (when entry 154 | (prepare-cleanup entry hash) 155 | (decf (slot-value cache 'size) (slot-value entry 'size)) 156 | (when policy 157 | (entry-removed policy entry))))) 158 | (flet ((miss () 159 | (let ((entry (make-instance 'cache-entry :key key :pending (bt:make-condition-variable)))) 160 | (setf (gethash key hash) entry) 161 | (values nil entry)))) 162 | (loop 163 | (let ((entry (gethash key hash))) 164 | (cond ((and (null entry) 165 | only-if-cached) 166 | ;; cache miss, and no waiting 167 | (return (values t nil nil))) 168 | 169 | ((null entry) 170 | ;; cache miss - initialize fetch from source 171 | (return (miss))) 172 | 173 | ((and (slot-boundp entry 'pending) 174 | only-if-cached) 175 | ;; cache hit - but data not yet ready, and no waiting 176 | (return (values t nil nil))) 177 | 178 | ((slot-boundp entry 'pending) 179 | ;; cache hit - but data not yet ready 180 | (let ((pending (slot-value entry 'pending))) 181 | (bt:condition-wait pending lock) 182 | ;; note: the pending slot is no longer bound after the wait 183 | (bt:condition-notify pending) 184 | ;; data now available 185 | (when (eq (gethash key hash) entry) 186 | ;; ... and not immediately cleaned up 187 | (if (cache-cleanup cache) 188 | (progn 189 | (if (>= (entry-busy entry) 0) 190 | (incf (entry-busy entry)) 191 | (decf (entry-busy entry))) 192 | (return (values t (slot-value entry 'data) entry))) 193 | (return (values t (slot-value entry 'data))))))) 194 | 195 | ((and entry policy 196 | (or (and (slot-boundp entry 'expiry) 197 | (<= (slot-value entry 'expiry) 198 | (get-universal-time))) 199 | (and (>= (entry-busy entry) 0) 200 | (not (access-entry policy entry))))) 201 | ;; cached data has expired or been invalidated 202 | (remhash key hash) 203 | (prepare-cleanup entry hash) 204 | (decf (slot-value cache 'size) (slot-value entry 'size)) 205 | (entry-removed policy entry) 206 | (if only-if-cached 207 | (return (values t nil nil)) ; no waiting 208 | (return (miss)))) 209 | 210 | ((cache-cleanup cache) 211 | (if (>= (entry-busy entry) 0) 212 | (incf (entry-busy entry)) 213 | (decf (entry-busy entry))) 214 | (return (values t (slot-value entry 'data) entry))) 215 | 216 | (t 217 | (return (values t (slot-value entry 'data) nil)))))))) 218 | (if hit 219 | (values data entry) 220 | (multiple-value-bind (content size) 221 | (handler-case (funcall provider key) 222 | (error (e) 223 | (bt:with-lock-held (lock) 224 | (remhash key hash) 225 | (bt:condition-notify (slot-value data 'pending)) 226 | (slot-makunbound data 'pending)) 227 | (error e))) 228 | (with-collected-cleanups (cache) 229 | (unless (typep size 'real) 230 | (setf size (if content 1 0)) 231 | (warn "Cache provider did not return a proper size for the data - assuming size of ~d" size)) 232 | (bt:with-lock-held (lock) 233 | (setf (slot-value data 'data) content 234 | (slot-value data 'size) size) 235 | (with-slots (lifetime) cache 236 | (when lifetime 237 | (setf (slot-value data 'expiry) 238 | (+ (get-universal-time) lifetime)))) 239 | (bt:condition-notify (slot-value data 'pending)) 240 | (slot-makunbound data 'pending) 241 | (incf (slot-value cache 'size) size) 242 | (when policy 243 | (ensure-cache-size cache) 244 | (entry-added policy data)) 245 | (if (cache-cleanup cache) 246 | (progn 247 | (incf (entry-busy data)) 248 | (values content data)) 249 | (values content nil)))))))))) 250 | 251 | (defmethod cache-release ((cache cache) entry) 252 | "Releases a reference for an item fetched earlier. 253 | An item fetched from the cache with cache-fetch will not be cleaned up before it is released." 254 | (when entry 255 | (with-slots (lock hash cleanup) cache 256 | (let ((to-clean (bt:with-lock-held (lock) 257 | (let ((busy (entry-busy entry))) 258 | (cond ((zerop busy) 259 | (error "Double release for item with the key ~a" (entry-key entry))) 260 | ((> busy 0) 261 | (decf (entry-busy entry)) 262 | nil) 263 | (t 264 | (when (zerop (incf (entry-busy entry))) 265 | (when (eq (gethash (entry-key entry) hash) entry) 266 | (remhash (entry-key entry) hash)) 267 | (slot-value entry 'data)))))))) 268 | (when (and cleanup to-clean) 269 | (funcall cleanup to-clean))))) 270 | nil) 271 | 272 | (defmacro with-cache-fetch (var (cache key &key only-if-cached) &body body) 273 | "Combines a cache-fetch and cache-release in a form." 274 | (let ((c-var (gensym)) 275 | (tag (gensym))) 276 | `(let ((,c-var ,cache)) 277 | (multiple-value-bind (,var ,tag) 278 | (cache-fetch ,c-var ,key ,@(and only-if-cached '(:only-if-cached t))) 279 | (unwind-protect 280 | (progn ,@body) 281 | (cache-release ,c-var ,tag)))))) 282 | 283 | (defmethod cache-remove ((cache cache) key) 284 | "Remove the item with the specified key from the cache." 285 | (with-slots (lock hash policy size) cache 286 | (with-collected-cleanups (cache) 287 | (bt:with-lock-held (lock) 288 | (let ((entry (gethash key hash))) 289 | (when entry 290 | (prepare-cleanup entry hash) 291 | (decf size (slot-value entry 'size)) 292 | (when policy 293 | (entry-removed policy entry)) 294 | t)))))) 295 | 296 | (defmethod cache-flush ((cache cache)) 297 | "Flush the cache, removing all items currently stored in it. If a cleanup function is defined for the cache, it is called for every item." 298 | (with-slots (lock hash policy size cleanup) cache 299 | (with-collected-cleanups (cache) 300 | (bt:with-lock-held (lock) 301 | (maphash #'(lambda (k v) 302 | (declare (ignore k)) 303 | (prepare-cleanup v hash) 304 | (entry-removed policy v)) 305 | hash) 306 | (setf size 0))) 307 | nil)) 308 | 309 | (defmethod cache-sanity-check ((cache cache)) 310 | (with-slots (lock hash policy size) cache 311 | (bt:with-lock-held (lock) 312 | (let ((seen (make-hash-table :test 'eq))) 313 | (dolist (i (list-entries policy)) 314 | (let ((v (gethash (entry-key i) hash))) 315 | (unless v 316 | (error "Cachen entry missing from hashtable: ~s" i)) 317 | (unless (eq i v) 318 | (error "Cache entry mismatch: ~s in hashtable, ~s in policy" v i))) 319 | (setf (gethash i seen) t)) 320 | (let ((total 0)) 321 | (maphash #'(lambda (k v) 322 | (declare (ignore k)) 323 | (when (>= (entry-busy v) 0) 324 | (unless (gethash v seen) 325 | (error "Cache entry missing from policy: ~s" v)) 326 | (incf total (entry-size v)))) 327 | hash) 328 | (unless (= total size) 329 | (error "Cache size mismatch: cache reports ~a, sum of entries is ~a" size total)))))) 330 | t) 331 | 332 | #+5am 333 | (5am:test cache-basics-1 334 | "Ensure that correct items are returned and flush clears the cache." 335 | (with-testing-cache (cache 200 :policy :fifo :without-cleanup t) 336 | (let ((items (loop for i from 1 to 15 337 | for item = (cache-fetch cache i) 338 | do (5am:is (= (first item) i)) 339 | collect item))) 340 | (cache-sanity-check cache) 341 | (dolist (item items) 342 | (5am:is (eq item (cache-fetch cache (first item))))) 343 | (cache-flush cache) 344 | (cache-sanity-check cache) 345 | (dolist (item items) 346 | (let ((new (cache-fetch cache (first item)))) 347 | (5am:is (not (eq item new))) 348 | (5am:is (> (second new) 15)))) 349 | (cache-sanity-check cache)))) 350 | 351 | #+5am 352 | (5am:test cache-basics-2 353 | "Ensure that correct items are returned and everything is cleaned up on a flush." 354 | (with-testing-cache (cache 200 :policy :fifo) 355 | (let ((items (loop for i from 1 to 15 356 | for item = (fetch-and-release cache i) 357 | do (5am:is (= (first item) i)) 358 | collect item))) 359 | (cache-sanity-check cache) 360 | (dolist (item items) 361 | (5am:is (eq item (fetch-and-release cache (first item))))) 362 | (cache-flush cache) 363 | (cache-sanity-check cache) 364 | (dolist (item items) 365 | (5am:is (cleaned-up-p item))) 366 | (dolist (item items) 367 | (with-cache-fetch new (cache (first item)) 368 | (5am:is (not (eq item new))) 369 | (5am:is (not (cleaned-up-p new))) 370 | (5am:is (> (second new) 15)))) 371 | (cache-sanity-check cache)))) 372 | 373 | #+5am 374 | (5am:test cache-release 375 | "Ensure that items are cleaned up only after cache-release." 376 | (with-testing-cache (cache 100 :policy :fifo) 377 | (multiple-value-bind (a a-tag) 378 | (cache-fetch cache 50) 379 | (let ((b (fetch-and-release cache 49)) 380 | (c (fetch-and-release cache 30))) 381 | (5am:is (eq a (fetch-and-release cache 50))) 382 | (5am:is (not (cleaned-up-p a))) 383 | (5am:is (eq b (fetch-and-release cache 49))) 384 | (5am:is (not (cleaned-up-p b))) 385 | (5am:is (eq c (fetch-and-release cache 30))) 386 | (5am:is (not (cleaned-up-p c))) 387 | (cache-release cache a-tag) 388 | (5am:signals error (cache-release cache a-tag)) 389 | (5am:is (cleaned-up-p a)) 390 | (5am:is (not (eq a (fetch-and-release cache 50)))))))) 391 | 392 | #+5am 393 | (5am:test cache-size-limit 394 | "Ensure that cache handles its size limit properly." 395 | (with-testing-cache (cache 100 :policy :fifo) 396 | (let ((a (fetch-and-release cache 50)) 397 | (b (fetch-and-release cache 49)) 398 | (c (fetch-and-release cache 30))) 399 | (cache-sanity-check cache) 400 | (5am:is (cleaned-up-p a)) 401 | (5am:is (not (cleaned-up-p b))) 402 | (5am:is (not (cleaned-up-p c))) 403 | (let ((d (fetch-and-release cache 101))) 404 | (cache-sanity-check cache) 405 | (5am:is (cleaned-up-p b)) 406 | (5am:is (cleaned-up-p c)) 407 | (5am:is (not (cleaned-up-p d))) 408 | (let ((e (fetch-and-release cache 1))) 409 | (cache-sanity-check cache) 410 | (5am:is (cleaned-up-p d)) 411 | (5am:is (not (cleaned-up-p e)))))))) 412 | 413 | #+5am 414 | (5am:test cache-threading 415 | "Ensure that simulatenous requests from multiple threads are handled correctly." 416 | (let ((object 0) 417 | (lock (bt:make-lock "mutex for test cache"))) 418 | (flet ((provider (arg) 419 | (sleep 1) 420 | (bt:with-lock-held (lock) 421 | (values (list arg (incf object)) arg))) 422 | (cleanup (arg) 423 | (5am:is (listp arg)) 424 | (5am:is (= 2 (length arg))) 425 | (setf (second arg) :cleaned-up))) 426 | (let* ((cache (make-cache 100 #'provider :policy :fifo :cleanup #'cleanup)) 427 | (threads (loop for i below 32 428 | collect (let ((key (1+ (mod i 8)))) 429 | (bt:make-thread #'(lambda () 430 | (multiple-value-bind (item tag) 431 | (cache-fetch cache key) 432 | (cache-release cache tag) 433 | item)))))) 434 | (a (mapcar #'bt:join-thread threads)) 435 | (b (nthcdr 8 a)) 436 | (c (nthcdr 8 b)) 437 | (d (nthcdr 8 c))) 438 | (loop for ai in a 439 | for bi in b 440 | for ci in c 441 | for di in d 442 | for key from 1 443 | do (5am:is (listp ai)) 444 | do (5am:is (= 2 (length ai))) 445 | do (5am:is (= key (first ai))) 446 | do (5am:is (integerp (second ai))) 447 | do (5am:is (eq ai bi)) 448 | do (5am:is (eq ai ci)) 449 | do (5am:is (eq ai di))) 450 | (cache-sanity-check cache))))) 451 | 452 | #+5am 453 | (5am:test cache-expiry 454 | "Check that time-based automatic expiry works." 455 | (with-testing-cache (cache 100 :policy :fifo :lifetime 0) 456 | ;; zero-second lifetime means that the sme entry should never be returned twice 457 | (let ((a1 (fetch-and-release cache 20)) 458 | (b1 (fetch-and-release cache 29)) 459 | (a2 (fetch-and-release cache 20)) 460 | (b2 (fetch-and-release cache 29))) 461 | (5am:is (not (eq a1 a2))) 462 | (5am:is (not (eq b1 b2))) 463 | (5am:is (cleaned-up-p a1)) 464 | (5am:is (not (cleaned-up-p a2))) 465 | (multiple-value-bind (a3 tag-a3) 466 | (cache-fetch cache 20) 467 | (multiple-value-bind (a4 tag-a4) 468 | (cache-fetch cache 20) 469 | (5am:is (not (eq a2 a3))) 470 | (5am:is (not (eq a3 a4))) 471 | (5am:is (not (cleaned-up-p a3))) 472 | (5am:is (not (cleaned-up-p a4))) 473 | (cache-release cache tag-a3) 474 | (cache-release cache tag-a4) 475 | (5am:is (cleaned-up-p a3)) 476 | (cache-sanity-check cache)))))) 477 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cacle - Extensible Cache services for Common Lisp 2 | 3 | ## 1. Introduction 4 | 5 | cacle implements a generic cache management facility with configurable 6 | and extensible cache replacement policies. The actual cached data can 7 | be stored anywhere, with cacle taking charge of keeping track of which 8 | entry is to be discarded next when more space is needed for a new 9 | entry. 10 | 11 | cacle is built to be thread safe and thus ready to be used in 12 | multithreaded environments, such as web services. In case multiple 13 | threads request the same piece of data simultaneously, the data is 14 | only obtained from the data provider once, then distributed to all the 15 | threads that requested it. 16 | 17 | **Note!** While cacle itself is thread safe, the provider and cleanup 18 | functions are *not* called in a locked context, as they may take a 19 | long time to complete, during which fetches from the cache should be 20 | possible. It is on the user's responsibility to protect against 21 | potential thread conflicts in the provider and cleanup functions. 22 | 23 | ## 2. Installation 24 | 25 | cacle can be installed using Quicklisp: 26 | ```lisp 27 | * (ql:quickload "cacle") 28 | ; Loading "cacle" 29 | ("cacle") 30 | * (require "cacle") 31 | "cacle" 32 | NIL 33 | ``` 34 | 35 | ## 3. Examples 36 | 37 | ## 3.1. Walkthrough 38 | 39 | As cacle does not care about the nature of the data in the cache, nor 40 | where it comes from, it needs a *provider* function that is able to 41 | obtain a block of data, given the block's *key*. What the *key* is is 42 | up to the application; to cacle, it is just something that can 43 | function as a key to a hash table. Indeed, cacle stores the current 44 | contents of the cache in a hash table; the table's *test* can be 45 | specified when creating the cache. 46 | 47 | Let's introduce a provider that maps key *k* into a block *k* units 48 | long. As the block's data content, a simple string is constructed. 49 | Of course, the string is not of the length indicated by the provider, 50 | but that is exactly the point: cacle does not care what the data is. 51 | The string could, for example, be the name of the actual file that 52 | holds the contents of the data block. 53 | 54 | ```lisp 55 | * (defun test-provider (key) 56 | "A provider returns two values: The data for the element, and the element's size." 57 | (format t "Providing data for key ~a~%" key) 58 | ;; Fetching the data takes some time... 59 | (sleep 1) 60 | (values (format nil "value for ~a" key) 61 | key)) 62 | TEST-PROVIDER 63 | ``` 64 | 65 | Now we are ready to create a cache that manages these blocks of data. 66 | 67 | ```lisp 68 | * (defparameter *my-cache* (cacle:make-cache 100 #'test-provider :policy :lru)) 69 | *MY-CACHE* 70 | * (cacle:cache-max-size *my-cache*) 71 | 100 72 | * (cacle:cache-size *my-cache*) 73 | 0 74 | * (cacle:cache-count *my-cache*) 75 | 0 76 | ``` 77 | 78 | So, the cache is empty. Let's fetch some data. 79 | 80 | ```lisp 81 | * (cacle:cache-fetch *my-cache* 42) 82 | Providing data for key 42 83 | "value for 42" 84 | NIL 85 | ``` 86 | 87 | Note the one-second delay in the function call. The function returned 88 | two values; meaning of the second value (here `NIL`) will be discussed 89 | later in this document. 90 | 91 | etching the same data again does not cause a call to the provider, 92 | with the value returned immediately. 93 | 94 | ```lisp 95 | * (cacle:cache-fetch *my-cache* 42) 96 | "value for 42" 97 | NIL 98 | * (cacle:cache-fetch *my-cache* 42) 99 | "value for 42" 100 | NIL 101 | ``` 102 | 103 | Next, widen the scope of requested items: 104 | 105 | ```lisp 106 | * (cacle:cache-fetch *my-cache* 17) 107 | Providing data for key 17 108 | "value for 17" 109 | NIL 110 | * (cacle:cache-fetch *my-cache* 33) 111 | Providing data for key 33 112 | "value for 33" 113 | NIL 114 | * (cacle:cache-fetch *my-cache* 42) 115 | "value for 42" 116 | NIL 117 | * (cacle:cache-size *my-cache*) 118 | 92 119 | * (cacle:cache-count *my-cache*) 120 | 3 121 | ``` 122 | 123 | The cache is already quite full, with 92 units out of 100 used. What 124 | happens if we now request data with a fresh key? 125 | 126 | ```lisp 127 | * (cacle:cache-fetch *my-cache* 24) 128 | Providing data for key 24 129 | "value for 24" 130 | * (cacle:cache-size *my-cache*) 131 | 99 132 | * (cacle:cache-count *my-cache*) 133 | 3 134 | ``` 135 | 136 | One of the stored blocks of data needs to go. Since of the three keys 137 | in the cache, both 42 and 33 have been referenced after 17, 17 has been 138 | discarded: 139 | 140 | ```lisp 141 | * (mapcar #'(lambda (key) 142 | (cacle:cache-fetch *my-cache* key :only-if-cached t)) 143 | '(42 17 33 24)) 144 | ("value for 42" NIL "value for 33" "value for 24") 145 | ``` 146 | 147 | Setting the *:only-if-cached* option prevents the calling of the 148 | provider if the queried data is not found in the cache, just returning 149 | *NIL* instead. 150 | 151 | If multiple threads request the same data, the provider is only called 152 | once, with all threads eventually getting the same result data: 153 | 154 | ```lisp 155 | * (loop with out = *standard-output* 156 | for i below 10 157 | collect (bt:make-thread #'(lambda () 158 | (let ((*standard-output* out)) 159 | (cacle:cache-fetch *my-cache* 72))))) 160 | Providing data for key 72 161 | (# # # # # # # # # #) 162 | * (mapcar #'bt:join-thread *) 163 | ("value for 72" "value for 72" "value for 72" "value for 72" "value for 72" "value for 72" "value for 72" "value for 72" "value for 72" "value for 72") 164 | * (loop with first = (first *) 165 | for i in * 166 | always (eq i first)) 167 | T 168 | ``` 169 | 170 | Finally, get rid of all the cached data: 171 | 172 | ```lisp 173 | * (cacle:cache-flush *my-cache*) 174 | NIL 175 | * (cacle:cache-size *my-cache*) 176 | 0 177 | * (cacle:cache-count *my-cache*) 178 | 0 179 | ``` 180 | 181 | To facilitate situations where data expiring from the cache needs some 182 | cleaning up - such as in the abovementioned case of the cache being on 183 | the disk - an optional cleanup function can be defined for the cache. 184 | This function is called whenever a block of data is discarded from the 185 | cache. 186 | 187 | ```lisp 188 | * (defun test-cleanup (data) 189 | (format t "Cleaning up: ~a~%" data)) 190 | TEST-CLEANUP 191 | * (setf *my-cache* (cacle:make-cache 100 #'test-provider :policy :lru :cleanup #'test-cleanup)) 192 | # 193 | ``` 194 | 195 | As cacle is designed to be used on multiple threads, a situation may 196 | arise where multiple threads request data from the cache 197 | simultaneously and an entry is removed from the cache by another 198 | thread before the thread that requested it can use the data. To 199 | prevent this situation, when a cleanup function has been defined for 200 | the cache, each call to *cache-fetch* must be paired with a call to 201 | *cache-release*. The release function is given as an argument the 202 | second value returned by *cache-fetch*. The cleanup function will not 203 | be called for the data if there are live references (fetches without 204 | corresponding releases) for the data. 205 | 206 | ```lisp 207 | * (defparameter *42* (multiple-value-list (cacle:cache-fetch *my-cache* 42))) 208 | Providing data for key 42 209 | *42* 210 | * *42* 211 | ("value for 42" #) 212 | ``` 213 | 214 | The tag datum should be treated opaque by the caller and used only as 215 | an argument to *cache-release*. 216 | 217 | A utility macro, *with-cache-fetch*, is provided for ensuring the 218 | pairing of *cache-fetch* and *cache-release*: 219 | 220 | ```lisp 221 | * (cacle:with-cache-fetch item (*my-cache* 17) 222 | (format t "my data: ~a~%" item)) 223 | Providing data for key 17 224 | my data: value for 17 225 | NIL 226 | * (cacle:with-cache-fetch item (*my-cache* 33) 227 | (format t "my data: ~a~%" item)) 228 | Providing data for key 33 229 | my data: value for 33 230 | NIL 231 | * (cacle:with-cache-fetch item (*my-cache* 24) 232 | (format t "my data: ~a~%" item)) 233 | Providing data for key 24 234 | my data: value for 24 235 | NIL 236 | * (cacle:with-cache-fetch item (*my-cache* 55) 237 | (format t "my data: ~a~%" item)) 238 | Providing data for key 55 239 | Cleaning up: value for 33 240 | Cleaning up: value for 17 241 | my data: value for 55 242 | NIL 243 | ``` 244 | 245 | Note that even before the last function call, the item for the key 42 246 | has already expired from the cache, since the total would otherwise 247 | exceed the cache's limit of 100. However, it has not been cleaned up, 248 | because it is still reserved by the very first call to *cache-fetch* 249 | that has not been matched with the call to *cache-release* yet. 250 | 251 | ```lisp 252 | * (cacle:cache-release *my-cache* (second *42*)) 253 | Cleaning up: value for 42 254 | NIL 255 | ``` 256 | 257 | **Note!** This example also demonstrates a property in the design of cacle that 258 | should be understood before using it: The maximum size defined for the 259 | cache is the size of the live objects in the cache and does not 260 | include items that have already been scheduled for removal, pending a 261 | call to *cache-release*, or items that are being fetched to the cache. 262 | That is, the total size of the cache may exceed its limit by the 263 | combined size of the items currently being used by the application. 264 | 265 | ### 3.2. A simple CDN node 266 | 267 | A simple node in a content distribution network could be built using 268 | cacle as follows. The content being distributed is fetched from a 269 | content server, and the cache resides on the local disk. 270 | 271 | *Warning: untested code - written as an example, not to be used as a 272 | real world CDN* 273 | 274 | ``` 275 | (defparameter *content-server* "http://server.example.com/") 276 | (defparameter *disk-space* #x1000000000) ;; 64 GB 277 | (defparameter *cache-path* "/var/cache/%") 278 | 279 | (defun fetch-content (uri) 280 | ;; This provider function retrieves data from the content server 281 | (let* (size 282 | (file (fad:with-output-to-temporary-file (out :template *cache-path* 283 | :element-type '(unsigned-byte 8)) 284 | (multiple-value-bind (in status) 285 | (drakma:http-request (concatenate 'string *content-server* uri) 286 | :want-stream t) 287 | ;; Copy the retrieved data into a file 288 | (when (<= 200 status 299) 289 | (fad:copy-stream in out) 290 | (setf size (file-length out))))))) 291 | (if size 292 | (values file size) ; success 293 | (progn ; error 294 | (ignore-errors (delete-file file)) 295 | (values nil 0))))) 296 | 297 | (defun cleanup-content (file) 298 | ;; When content removed from the cache, delete the corresponding file 299 | (ignore-errors (delete-file file))) 300 | 301 | ;; Set object lifetime to 3600 seconds to force a refresh once per hour 302 | (defparameter *cache* (cacle:make-cache *disk-space* #'fetch-content 303 | :test 'equal 304 | :cleanup #'cleanup-content 305 | :policy :lfuda 306 | :lifetime 3600)) 307 | 308 | ;; Function called by the web server to serve a certain file 309 | (defun serve-file (uri) 310 | (cacle:with-cache-fetch file (*cache* uri) 311 | (if file 312 | (progn 313 | ;; Send back the data in file 314 | ...) 315 | (progn 316 | ;; Report a 404 not found 317 | )))) 318 | ``` 319 | 320 | That's it. On an incoming request, *serve-file* will fetch the 321 | corresponding content from a file in the cache. If the content is not 322 | cached, it is transparently fetched from the content server, stored in 323 | the cache, and sent to the end user. 324 | 325 | ## 4. Cache replacement policies 326 | 327 | A [cache replacement 328 | policy](https://en.wikipedia.org/wiki/Cache_replacement_policies) 329 | defines how existing entries are discarded from the cache to make room 330 | for the data that is currently being loaded. cacle implements a set 331 | of simple replacement policies and provides means for the user to 332 | build their own policy, if necessary. Additionally, a lifetime can be 333 | defined for the cache, after which cached data expires and a fresh 334 | copy is obtained instead. 335 | 336 | The following cache replacement policies are implemented: 337 | 338 | * First In First Out (*:fifo*): Data that has been in the cache for the longest time is discarded 339 | * Last In First Out (*:lifo*): Most recently added data is discarded 340 | * Least Recently Used (*:lru*): Data that has gone unused for the longest time is discarded 341 | * Most Recently Used (*:mru*): Most recently used data is discarded 342 | * Random (*:random*): A randomly selected piece of data is discarded 343 | * Least Frequently Used (*:lfu*): Data with the lowest number of fetches is discarded 344 | * Least Frequently Used with Dynamic Aging (*:lfuda*): An aging variable is introduced to LFU to prefer discarding data that has been used a lot in the history but less often recently. 345 | 346 | ### 4.1. Creating your own replacement policy 347 | 348 | Each cache replacement policy is responsible of keeping track of all 349 | the entries currently in the cache. A suitable daata structure should 350 | be chosen so that the relevant operations are as fast as possible. 351 | 352 | A policy is a class that is instantiated once per a cache managed by 353 | the policy. Policies should be built as the 354 | *replacement-policy* class as the superclass. Additionally, a 355 | number of derived classes, listed in the next section, are exported by 356 | *cacle* and can be used as basis for a custom policy. 357 | 358 | To be able to store entries in the policy's desired manner, each cache 359 | entry must be able to hold certain policy specific data. To 360 | accommodate this, policies may define specializations of the cache 361 | entry base class *cache-entry*. Policies must treat the base 362 | class opaque and access the base class's data only through the 363 | exported readers (*entry-key*, *entry-size* and 364 | *entry-expiry*). Policies can add slots as necessary for 365 | their own operation, and *change-class* of an entry-to-be-added in the 366 | *entry-added* generic function. 367 | 368 | For example, *linked-list-replacement-policy* stores the entries 369 | in a circular doubly linked list to serve simple policies such as FIFO 370 | or LRU. In a list structure, insertion and removal of entries are 371 | constant time operations, but lookups for entries other than the first 372 | or last are costly. The respective cache entry class, 373 | *linked-cache-entry*, defines two additional slots that hold the 374 | forward and backward pointers: 375 | 376 | ```lisp 377 | (defclass linked-cache-entry (cache-entry) 378 | ((next) 379 | (prev))) 380 | ``` 381 | 382 | The replacement policy class itself holds the head of the list of 383 | entries, and, when a new entry is added to cache, changes the entry's 384 | class and pushes it at the head of the list. The call to 385 | *change-class* is done in a *:before* method so that classes derived 386 | from *linked-list-replacement-policy* do not need to remember to 387 | *(call-next-method)* in their *entry-added* method implementations. 388 | 389 | ```lisp 390 | (defclass linked-list-replacement-policy (replacement-policy) 391 | ((head :initform (make-instance 'linked-cache-entry)))) 392 | 393 | (defmethod entry-added :before ((policy linked-list-replacement-policy) (entry cache-entry)) 394 | (change-class entry 'linked-cache-entry)) 395 | 396 | (defmethod entry-added ((policy linked-list-replacement-policy) (entry cache-entry)) 397 | (link-after entry (slot-value policy 'head))) 398 | ``` 399 | 400 | The following classes have been implemented for the bundled 401 | replacement policies: 402 | 403 | * *fifo-replacement-policy* 404 | * *lifo-replacement-policy* 405 | * *lru-replacement-policy* 406 | * *mru-replacement-policy* 407 | * *random-replacement-policy* 408 | * *lfu-replacement-policy* 409 | * *lfuda-replacement-policy*. 410 | 411 | *lfu-replacement-policy* uses a heap structure to store entries in 412 | their changing order of precedence. *lfuda-replacement-policy* builds 413 | on it. 414 | 415 | ## 5. Dictionary 416 | 417 | ### 5.1. The cache class 418 | 419 | [Standard class] **cache** 420 | 421 | *cache* is the main class of the system. It contains 422 | information abnout the data blocks currently stored in a certain 423 | cache. Note that while storing the information, *cache* leaves the 424 | storage of the actual data to the user: The data could be, for 425 | example, a vector of octets directly linked to the entry; a certain 426 | file in the filesystem; or a bunch of bananas in the storage room of 427 | a zoo. 428 | 429 | While you can create an instance of *cache* directly with 430 | *make-instance*, it is recommended to use the convenience function 431 | *make-cache*. 432 | 433 | --- 434 | [Generic reader] **cache-max-size** *cache* => *number* 435 | 436 | [Generic writer] (setf (**cache-max-size** *cache*) *new-max-size*) 437 | 438 | Retrieves or sets the maximum cache size. 439 | 440 | --- 441 | [Generic reader] **cache-provider** *cache* => *function* 442 | 443 | [Generic writer] (setf (**cache-provider** *cache*) *new-provider*) 444 | 445 | Retrieves or sets the cache's provider function. 446 | 447 | --- 448 | [Generic reader] **cache-cleanup** *cache* => *function* 449 | 450 | [Generic writer] (setf (**cache-cleanup** *cache*) *new-cleanup*) 451 | 452 | Retrieves or sets the cache's cleanup function. 453 | 454 | --- 455 | [Generic reader] **cache-lifetime** *cache* => *number* 456 | 457 | [Generic writer] (setf (**cache-lifetime** *cache*) *new-lifetime*) 458 | 459 | Retrieves or sets the cache object lifetime in seconds. 460 | 461 | --- 462 | [Generic reader] **cache-policy** *cache* => *replacement-policy* 463 | 464 | Retrieves the cache's replacement policy. 465 | 466 | --- 467 | [Generic function] **cache-size** *cache* => *number* 468 | 469 | Returns the sum of the sizes of data items currently stored in the 470 | cache. 471 | 472 | --- 473 | [Generic function] **cache-count** *cache* => *integer* 474 | 475 | Returns the number of data items currently stroed in the cache. 476 | 477 | ### 5.2. Cache functions 478 | 479 | [Function] **make-cache** *max-size provider &key (test 'eql) (policy :fifo) lifetime cleanup* => *cache* 480 | 481 | This function creates a new cache instance with the specified maximum 482 | size and provider function. 483 | 484 | *max-size* defines the cache's capacity in some units of the 485 | application's choice - for example, bytes, kilograms, or bananas. 486 | 487 | *provider* must be a function that takes a single argument, key of the 488 | data to provide, and returns two values: the data and its size. 489 | 490 | *test* is the same as *make-hashtable*'s *test* and affects the 491 | cache's underlying hashtable for key equality comparisons. 492 | 493 | *policy* defines the cache replacement policy. It must be *NIL* if 494 | and only if *max-size* is NIL as well. To specify a policy from the 495 | set offered by cacle, you can use a keyword (*:fifo*, *:lifo*, *:lru*, 496 | *:mru*, *:random*, *:lfu* or *:lfuda*). To use a custom removal 497 | policy, pass an instance of the policy class. 498 | 499 | *lifetime* defines an optional object lifetime in seconds. If 500 | *lifetime* is defined, *cache-fetch* will not return objects returned 501 | by *provider* longer than this time ago. 502 | 503 | *cleanup* defines an optional callback function to be called for data 504 | that is being discarded from the cache. The function receives a 505 | single parameter - the data - and its return value is discarded. 506 | 507 | --- 508 | [Generic function] **cache-fetch** *cache &key only-if-cached force-fetch* => *(values datum tag)* 509 | 510 | Fetches a datum from the cache for the given key. If the datum is not 511 | currently cached and the *only-if-cached* flag is not set, it is 512 | retrieved from the provider function, added to the cache, and then 513 | returned. The *tag* return value must be specified in a corresponding 514 | call to *cache-release* before it will be cleaned up. 515 | 516 | If the *force-fetch* flag is set, the fetch is atomically preceded by 517 | a call to *cache-release*, effectively fetching a new value from the 518 | provider. 519 | 520 | --- 521 | [Generic function] **cache-release** *cache tag* => *NIL* 522 | 523 | Releases a reference obtained by a call to *cache-fetch*. 524 | 525 | --- 526 | [Macro] **with-cache-fetch** *var (cache key &key only-if-cached) &body body* 527 | 528 | Wraps the given body between calls to *cache-fetch* and 529 | *cache-release*, ensuring that the data fetched from the cache is 530 | valid inside *body* and will be released afterwards. 531 | 532 | --- 533 | [Generic function] **cache-remove** *cache key* => *(or T NIL)* 534 | 535 | Removes the datum for the specified key from the cache. Returns *T* 536 | if the data was currently cached, *NIL* otherwise. 537 | 538 | --- 539 | [Generic function] **cache-flush** *cache* => *NIL* 540 | 541 | Removes all entries from the cache. 542 | 543 | ### 5.3. Cache removal policies 544 | 545 | [Standard class] **cache-entry** 546 | 547 | Base class for cache entries. All entries are created as instances of 548 | this class, but the active removal policy may change the entry's class 549 | in the call to *entry-added*. 550 | 551 | [Generic reader] **entry-key** 552 | 553 | [Generic reader] **entry-valid-p** 554 | 555 | [Generic reader] **entry-size** 556 | 557 | [Generic reader] **entry-expiry** 558 | 559 | Readers for the cache entry's basic information. **entry-size** will 560 | signal an *unbound-slot* condition when the entry is not valid (when 561 | **entry-valid-p** returns *NIL*). 562 | 563 | To ensure thread safety, these functions must not be used outside of 564 | the cache removal policy callback functions *entry-added*, 565 | *access-entry*, *entry-removed* and *evict-entry*. The same 566 | restriction applies to all functions related to cache entries. 567 | 568 | --- 569 | [Standard class] **linked-cache-entry** 570 | 571 | Cache entry that can be stored in a circular doubly linked list for 572 | bookkeeping. 573 | 574 | [Generic reader] **entry-next** *linked-cache-entry* => *linked-cache-entry* 575 | 576 | [Generic reader] **entry-previous** *linked-cache-entry* => *linked-cache-entry* 577 | 578 | [Generic function] **unlink** *linked-cache-entry* => *linked-cache-entry* 579 | 580 | [Generic function] **link-before** *linked-cache-entry linked-cache-entry* => *linked-cache-entry* 581 | 582 | [Generic function] **link-after** *linked-cache-entry linked-cache-entry* => *linked-cache-entry* 583 | 584 | These functions traverse and modify the doubly linked list formed by 585 | the entries. Each *linked-cache-entry* starts as a one-entry-long 586 | list of its own, liked to itself in both directions. 587 | 588 | --- 589 | [Standard class] **indexed-cache-entry** 590 | 591 | An indexed cache entry simply associates a free-form index with each cache entry. 592 | 593 | [Generic reader] **entry-index** *indexed-cache-entry* => *value* 594 | 595 | [Generic writer] (setf (**entry-index** *indexed-cache-entry*) *new-index*) 596 | 597 | --- 598 | [Standard class] **replacement-policy** 599 | 600 | Base class for all replacement policies. 601 | 602 | [Generic function] **entry-added** *policy entry* => *anything* 603 | 604 | The cache calls this function for each new cache entry. The policy 605 | should initialize whatever bookkeeping is necessary; usually, this 606 | begins with changing the class of the entry to something able to hold 607 | the bookkeeping information. 608 | 609 | [Generic function] **access-entry** *policy entry* => *(or T NIL)* 610 | 611 | When an entry is accessed in the cache, this function is called. The 612 | function should verify that the entry is still valid and update the 613 | bookkeeping data related to entry accesses. Returning *T* means that 614 | the entry is still valid and should be returned to the caller; 615 | returning *NIL* removes the entry and results in a new call to the 616 | provider. 617 | 618 | Note that *access-entry* is not called for the very first access (when 619 | *entry-added* is called). 620 | 621 | [Generic function] **entry-removed** *policy entry* => *anything* 622 | 623 | This function notifies the policy that an entry has been removed from 624 | the cache. The policy should update its bookkeeping data to keep 625 | track of the situation. 626 | 627 | [Generic function] **evict-entry** *policy size-hint* => *cache-entry* 628 | 629 | When the cache space runs out, this function is called for the policy. 630 | The policy instance should decide which of the currently present 631 | entries is to be discarded to make room for the new one, remove it 632 | from its books, and return the entry. 633 | 634 | The *size-hint* parameter tells how much space needs to be freed from 635 | the cache in order to fit in the new entry; the policy may use this 636 | information if it wishes. If not enough space is freed by the 637 | returned *cache-entry*, the cache simply calls *evict-entry* again 638 | until enough space has been freed. 639 | 640 | Note that *entry-removed* is not called for the entry returned by 641 | *evict-entry*. 642 | 643 | --- 644 | [Standard class] **linked-list-replacement-policy** 645 | 646 | This policy stores entries in a linked list, pushing any new items 647 | after the head. *evict-entry* is not implemented, so the class cannot 648 | be directly used as a replacement policy. 649 | 650 | [Generic reader] **linked-list-head** *linked-list-replacement-policy* => *linked-cache-entry* 651 | 652 | Returns the head node of the linked list. The head node is a 653 | sentinel; it is a *linked-cache-entry* without a key or data, simply 654 | serving as a point for attaching the actual data nodes. 655 | 656 | --- 657 | [Standard class] **fifo-replacement-policy** 658 | 659 | [Standard class] **lifo-replacement-policy** 660 | 661 | [Standard class] **lru-replacement-policy** 662 | 663 | [Standard class] **mru-replacement-policy** 664 | 665 | [Standard class] **random-replacement-policy** 666 | 667 | [Standard class] **lfu-replacement-policy** 668 | 669 | [Standard class] **lfuda-replacement-policy** 670 | 671 | These classes implement their respective cache replacement policies. 672 | 673 | ## 6. Tests 674 | 675 | Unit tests for cacle are written using 676 | [FiveAM](https://common-lisp.net/project/fiveam/). They are hidden 677 | behind the *#+5am* read-time conditional; to enable the tests, load 678 | FiveAM before compiling cacle. After that, you can run the test suite 679 | from the REPL: 680 | 681 | ```lisp 682 | * (5am:run! 'cacle:cacle-tests) 683 | 684 | Running test suite CACLE-TESTS 685 | Running test [...] 686 | [...] 687 | Did 619 checks. 688 | Pass: 619 (100%) 689 | Skip: 0 ( 0%) 690 | Fail: 0 ( 0%) 691 | 692 | NIL 693 | ``` 694 | 695 | ## 7. License 696 | 697 | [MIT](https://opensource.org/licenses/MIT) 698 | --------------------------------------------------------------------------------