(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))))
+ (declare (index length))
(when (< length +cache-vector-max-length+)
(setf length (* 2 length)))
(tagbody
(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))))
+ ;; 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 cache))
(map-cache (lambda (layouts value)
(unless (try-update-cache copy layouts value)
;; If the cache would grow too much we drop the
;; we just drop the invalid entries.
(%fill-cache (copy-cache cache) layouts value))
(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))))
(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