;;;;
;;;; * Since the cache is used for memoization only we don't need to
;;;; worry about which of simultaneous replacements (when expanding
-;;;; the cache) takes place: the loosing one will have its work
+;;;; the cache) takes place: the losing one will have its work
;;;; redone later. This also allows us to drop entries when the
;;;; cache is about to grow insanely huge.
;;;;
;; (mod index (length vector))
;; using a bitmask.
(vector #() :type simple-vector)
- ;; The bitmask used to calculate (mod (* line-size line-hash) (length vector))).
+ ;; The bitmask used to calculate
+ ;; (mod (* line-size line-hash) (length vector))).
(mask 0 :type fixnum)
;; Current probe-depth needed in the cache.
(depth 0 :type index)
;; bits at the low end.
(logand (1- vector-length) (- line-size)))
-;;; The smallest power of two that is equal to or greater then X.
-(declaim (inline power-of-two-ceiling))
-(defun power-of-two-ceiling (x)
- (ash 1 (integer-length (1- x))))
-
(defun cache-statistics (cache)
(let* ((vector (cache-vector cache))
(size (length vector))
(values (- total-lines free-lines) total-lines
(cache-depth cache) (cache-limit cache))))
-;;; Don't allocate insanely huge caches.
-(defconstant +cache-vector-max-length+ (expt 2 14))
+;;; Don't allocate insanely huge caches: this is 4096 lines for a
+;;; value cache with 8-15 keys -- probably "big enough for anyone",
+;;; and 16384 lines for a commonplace 2-key value cache.
+(defconstant +cache-vector-max-length+ (expt 2 16))
;;; Compute the maximum allowed probe depth as a function of cache size.
;;; Cache size refers to number of cache lines, not the length of the
(defun cache-key-p (thing)
(not (symbolp thing)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
- :structure cache
- :slot depth))
-
-;;; Utility macro for atomic updates without locking... doesn't
-;;; do much right now, and it would be nice to make this more magical.
-(defmacro compare-and-swap (place old new)
- (unless (consp place)
- (error "Don't know how to compare and swap ~S." place))
- (ecase (car place)
- (svref
- `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
- (cache-depth
- `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
-
;;; Atomically update the current probe depth of a cache.
(defun note-cache-depth (cache depth)
(loop for old = (cache-depth cache)
;;; Compute the starting index of the next cache line in the cache vector.
(declaim (inline next-cache-index))
(defun next-cache-index (mask index line-size)
+ (declare (type (unsigned-byte #.sb-vm:n-word-bits) index line-size mask))
(logand mask (+ index line-size)))
;;; Returns the hash-value for layout, or executes ELSE if the layout
;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
;;; value that is the value that was stored in the cache if any.
(defun probe-cache (cache layouts)
+ (declare (optimize speed))
(unless (consp layouts)
(setf layouts (list layouts)))
(let ((vector (cache-vector cache))
(line-size (cache-line-size cache))
(mask (cache-mask cache)))
(flet ((probe-line (base)
+ (declare (optimize (sb-c::type-check 0)))
(tagbody
- (loop for offset from 0 below key-count
+ (loop for offset of-type index from 0 below key-count
for layout in layouts do
(unless (eq layout (svref vector (+ base offset)))
;; missed
(return-from probe-cache (values t value)))
:miss
(return-from probe-line (next-cache-index mask base line-size)))))
+ (declare (ftype (function (index) (values index &optional)) probe-line))
(let ((index (compute-cache-index cache layouts)))
(when index
- (loop repeat (1+ (cache-depth cache)) do
- (setf index (probe-line index)))))))
+ (loop repeat (1+ (cache-depth cache))
+ do (setf index (probe-line index)))))))
(values nil nil))
;;; Tries to write LAYOUTS and VALUE at the cache line starting at
;;; true on success and false on failure, meaning the cache is too
;;; full.
(defun try-update-cache (cache layouts value)
- (let ((vector (cache-vector cache))
- (index (or (compute-cache-index cache layouts)
+ (let ((index (or (compute-cache-index cache layouts)
;; At least one of the layouts was invalid: just
;; pretend we updated the cache, and let the next
;; read pick up the mess.
;;;; Copies and expands the cache, dropping any invalidated or
;;;; incomplete lines.
-(defun copy-and-expand-cache (cache)
+(defun copy-and-expand-cache (cache layouts value)
(let ((copy (%copy-cache cache))
- (length (length (cache-vector cache))))
+ (length (length (cache-vector cache)))
+ (drop-random-entries nil))
+ (declare (index length))
(when (< length +cache-vector-max-length+)
(setf length (* 2 length)))
(tagbody
:again
- (setf (cache-vector copy) (make-array length :initial-element '..empty..)
+ ;; Blow way the old vector first, so a GC potentially triggered by
+ ;; MAKE-ARRAY can collect it.
+ (setf (cache-vector copy) #()
+ (cache-vector copy) (make-array length :initial-element '..empty..)
(cache-depth copy) 0
(cache-mask copy) (compute-cache-mask length (cache-line-size cache))
(cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
- (map-cache (lambda (layouts value)
- (unless (try-update-cache copy layouts value)
- ;; If the cache would grow too much we drop the
- ;; remaining the entries that don't fit. FIXME:
- ;; It would be better to drop random entries to
- ;; avoid getting into a rut here (best done by
- ;; making MAP-CACHE map in a random order?), and
- ;; possibly to downsize the cache more
- ;; aggressively (on the assumption that most
- ;; entries aren't getting used at the moment.)
- (when (< length +cache-vector-max-length+)
- (setf length (* 2 length))
- (go :again))))
+ ;; First insert the new one -- if we don't do this first and
+ ;; the cache has reached its maximum size we may end up looping
+ ;; in FILL-CACHE.
+ (unless (try-update-cache copy layouts value)
+ (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value copy))
+ (map-cache (if drop-random-entries
+ ;; The cache is at maximum size, and all entries
+ ;; do not fit in. Drop a random ~50% of entries,
+ ;; to make space for new ones. This needs to be
+ ;; random, since otherwise we might get in a
+ ;; rut: add A causing B to drop, then add B
+ ;; causing A to drop... repeat ad nauseam,
+ ;; spending most of the time here instead of
+ ;; doing real work. 50% because if we drop too
+ ;; few we need to do this almost right away
+ ;; again, and if we drop too many, we need to
+ ;; recompute more then we'd like.
+ ;; _Experimentally_ 50% seems to perform the
+ ;; best, but it would be nice to have a proper
+ ;; analysis...
+ (randomly-punting-lambda (layouts value)
+ (try-update-cache copy layouts value))
+ (lambda (layouts value)
+ (unless (try-update-cache copy layouts value)
+ ;; Didn't fit -- expand the cache, or drop
+ ;; a few unlucky ones.
+ (if (< length +cache-vector-max-length+)
+ (setf length (* 2 length))
+ (setf drop-random-entries t))
+ (go :again))))
cache))
copy))
;;; necessary, and returns the new cache.
(defun fill-cache (cache layouts value)
(labels
- ((%fill-cache (cache layouts value)
+ ((%fill-cache (cache layouts value expand)
(cond ((try-update-cache cache layouts value)
cache)
- ((cache-has-invalid-entries-p cache)
+ ((and (not expand) (cache-has-invalid-entries-p cache))
;; Don't expand yet: maybe there will be enough space if
;; we just drop the invalid entries.
- (%fill-cache (copy-cache cache) layouts value))
+ (%fill-cache (copy-cache cache) layouts value t))
(t
- (%fill-cache (copy-and-expand-cache cache) layouts value)))))
+ (copy-and-expand-cache cache layouts value)))))
(if (listp layouts)
- (%fill-cache cache layouts value)
- (%fill-cache cache (list layouts) value))))
+ (%fill-cache cache layouts value nil)
+ (%fill-cache cache (list layouts) value nil))))
;;; Calls FUNCTION with all layouts and values in cache.
(defun map-cache (function cache)
(fun (if (functionp function)
function
(fdefinition function)))
- (index 0)
- (key nil))
+ (index 0))
(tagbody
:map
(let ((layouts
(mask (cache-mask cache))
(size (/ (length vector) line-size))
(index 0)
- (elt nil)
(depth 0))
(tagbody
:copy