;;;;
;;;; * 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 index (length vector))l
+ ;; 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)
;; Maximum allowed probe-depth before the cache needs to expand.
(limit 0 :type index))
-;;; 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 compute-cache-mask (vector-length line-size)
+ ;; Since both vector-length and line-size are powers of two, we
+ ;; can compute a bitmask such that
+ ;;
+ ;; (logand <mask> <combined-layout-hash>)
+ ;;
+ ;; is "morally equal" to
+ ;;
+ ;; (mod (* <line-size> <combined-layout-hash>) <vector-length>)
+ ;;
+ ;; This is it: (1- vector-length) is #b111... of the approriate size
+ ;; to get the MOD, and (- line-size) gives right the number of zero
+ ;; bits at the low end.
+ (logand (1- vector-length) (- line-size)))
(defun cache-statistics (cache)
(let* ((vector (cache-vector cache))
(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
;;; policy into account here (speed vs. space.)
(declaim (inline compute-limit))
(defun compute-limit (size)
- (ceiling (sqrt size) 2))
+ (ceiling (sqrt (sqrt size))))
;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
(defmacro non-empty-or (value else)
(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
(defun compute-cache-index (cache layouts)
(let ((index (hash-layout-or (car layouts)
(return-from compute-cache-index nil))))
+ (declare (fixnum index))
(dolist (layout (cdr layouts))
(mixf index (hash-layout-or layout (return-from compute-cache-index nil))))
;; align with cache lines
- (logand (* (cache-line-size cache) index) (cache-mask cache))))
+ (logand index (cache-mask cache))))
;;; Emit code that does lookup in cache bound to CACHE-VAR using
;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
(with-unique-names (n-index n-vector n-depth n-pointer n-mask
MATCH-WRAPPERS EXIT-WITH-HIT)
`(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
- (,n-vector (cache-vector ,cache-var)))
+ (,n-vector (cache-vector ,cache-var))
+ (,n-mask (cache-mask ,cache-var)))
(declare (index ,n-index))
,@(mapcar (lambda (layout-var)
`(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
(cdr layout-vars))
;; align with cache lines
- (setf ,n-index (logand (* ,line-size ,n-index) (cache-mask ,cache-var)))
+ (setf ,n-index (logand ,n-index ,n-mask))
(let ((,n-depth (cache-depth ,cache-var))
- (,n-pointer ,n-index)
- (,n-mask (cache-mask ,cache-var)))
+ (,n-pointer ,n-index))
(declare (index ,n-depth ,n-pointer))
(tagbody
,MATCH-WRAPPERS
;;; 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.
:line-size line-size
:vector (make-array length :initial-element '..empty..)
:value value
- :mask (1- length)
+ :mask (compute-cache-mask length line-size)
:limit (compute-limit adjusted-size))
;; Make a smaller one, then
(make-cache :key-count key-count :value value :size (ceiling size 2)))))
;;;; 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) (1- length)
+ (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))
(defun cache-has-invalid-entries-p (cache)
- (and (find-if (lambda (elt)
- (and (typep elt 'layout)
- (zerop (layout-clos-hash elt))))
- (cache-vector cache))
- t))
+ (let ((vector (cache-vector cache))
+ (line-size (cache-line-size cache))
+ (key-count (cache-key-count cache))
+ (mask (cache-mask cache))
+ (index 0))
+ (loop
+ ;; Check if the line is in use, and check validity of the keys.
+ (let ((key1 (svref vector index)))
+ (when (cache-key-p key1)
+ (if (zerop (layout-clos-hash key1))
+ ;; First key invalid.
+ (return-from cache-has-invalid-entries-p t)
+ ;; Line is in use and the first key is valid: check the rest.
+ (loop for offset from 1 below key-count
+ do (let ((thing (svref vector (+ index offset))))
+ (when (or (not (cache-key-p thing))
+ (zerop (layout-clos-hash thing)))
+ ;; Incomplete line or invalid layout.
+ (return-from cache-has-invalid-entries-p t)))))))
+ ;; Line empty of valid, onwards.
+ (setf index (next-cache-index mask index line-size))
+ (when (zerop index)
+ ;; wrapped around
+ (return-from cache-has-invalid-entries-p nil)))))
(defun hash-table-to-cache (table &key value key-count)
(let ((cache (make-cache :key-count key-count :value value
;;; 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
(line-size (cache-line-size cache))
(key-count (cache-key-count cache))
(valuep (cache-value cache))
- (size (/ (length vector) line-size))
(mask (cache-mask cache))
+ (size (/ (length vector) line-size))
(index 0)
- (elt nil)
(depth 0))
(tagbody
:copy
:key-count (cache-key-count cache)
:line-size line-size
:value valuep
- :mask (cache-mask cache)
+ :mask mask
:limit (cache-limit cache))))
+
+;;;; For debugging & collecting statistics.
+
+(defun map-all-caches (function)
+ (dolist (p (list-all-packages))
+ (do-symbols (s p)
+ (when (eq p (symbol-package s))
+ (dolist (name (list s
+ `(setf ,s)
+ (slot-reader-name s)
+ (slot-writer-name s)
+ (slot-boundp-name s)))
+ (when (fboundp name)
+ (let ((fun (fdefinition name)))
+ (when (typep fun 'generic-function)
+ (let ((cache (gf-dfun-cache fun)))
+ (when cache
+ (funcall function name cache)))))))))))
+
+(defun check-cache-consistency (cache)
+ (let ((table (make-hash-table :test 'equal)))
+ (map-cache (lambda (layouts value)
+ (declare (ignore value))
+ (if (gethash layouts table)
+ (cerror "Check futher."
+ "Multiple appearances of ~S." layouts)
+ (setf (gethash layouts table) t)))
+ cache)))
projects / sbcl.git / blobdiff