X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=11659226a160638915212a61b60b9ce1f94ad2e1;hb=HEAD;hp=635799d1c3892102730d039b0627276c0de460f2;hpb=4f7c5ad9f9ef93c149ed4e45d4dce696863d324f;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 635799d..1165922 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -53,7 +53,7 @@ ;;;; ;;;; * 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. ;;;; @@ -81,17 +81,28 @@ ;; (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 ) + ;; + ;; is "morally equal" to + ;; + ;; (mod (* ) ) + ;; + ;; 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)) @@ -104,8 +115,10 @@ (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 @@ -115,7 +128,7 @@ ;;; 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) @@ -131,22 +144,6 @@ (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) @@ -157,6 +154,7 @@ ;;; 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 @@ -173,10 +171,11 @@ (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 @@ -192,16 +191,16 @@ (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 @@ -228,6 +227,7 @@ ;;; 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)) @@ -235,8 +235,9 @@ (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 @@ -248,10 +249,11 @@ (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 @@ -285,8 +287,7 @@ ;;; 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. @@ -311,46 +312,87 @@ :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 @@ -364,18 +406,18 @@ ;;; 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) @@ -387,8 +429,7 @@ (fun (if (functionp function) function (fdefinition function))) - (index 0) - (key nil)) + (index 0)) (tagbody :map (let ((layouts @@ -416,10 +457,9 @@ (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 @@ -452,5 +492,33 @@ :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)))