;; (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)
(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.
;; Make a smaller one, then
(make-cache :key-count key-count :value value :size (ceiling size 2)))))
+(defconstant n-fixnum-bits #.(integer-length most-positive-fixnum))
+
;;;; 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 it's 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 to
+ ;; few we need to do this almost right away
+ ;; again, and if we drop to 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...
+ (flet ((random-fixnum ()
+ (random (1+ most-positive-fixnum))))
+ (let ((drops (random-fixnum))
+ (drop-pos n-fixnum-bits))
+ (declare (fixnum drops)
+ (type (integer 0 #.n-fixnum-bits) drop-pos))
+ (lambda (layouts value)
+ (when (logbitp (the unsigned-byte (decf drop-pos)) drops)
+ (try-update-cache copy layouts value))
+ (when (zerop drop-pos)
+ (setf drops (random-fixnum)
+ drop-pos n-fixnum-bits)))))
+ (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