X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=e7f60e4d6502f28b7319652849c274c9c99cc9f4;hb=db770d287bb64a58967d08fdd8225c02cdd4d45a;hp=b4d3e9da829c97a3cc691ce2ec52255834c11dfa;hpb=6e953f60d904a015b3273db84b5886b04a9ecb1c;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index b4d3e9d..e7f60e4 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -149,22 +149,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) @@ -175,6 +159,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 @@ -247,6 +232,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)) @@ -254,8 +240,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 @@ -267,10 +254,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 @@ -304,8 +292,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. @@ -335,11 +322,15 @@ ;; 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 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 @@ -355,20 +346,42 @@ ;; 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 - ;; 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)))) + (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)) @@ -410,18 +423,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 (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) @@ -433,8 +446,7 @@ (fun (if (functionp function) function (fdefinition function))) - (index 0) - (key nil)) + (index 0)) (tagbody :map (let ((layouts @@ -465,7 +477,6 @@ (mask (cache-mask cache)) (size (/ (length vector) line-size)) (index 0) - (elt nil) (depth 0)) (tagbody :copy