X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=f70a2a8f8ac8f6e2350423a90357c0077896964b;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=bb148ffd4fee0457dfb9368b4d8b25458dccd4e5;hpb=90c2b0563695904419451b6172efcf9c7008ad8b;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index bb148ff..f70a2a8 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -81,7 +81,8 @@
   ;;   (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)
@@ -119,8 +120,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
@@ -146,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)
@@ -334,17 +321,25 @@
 
 ;;;; 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))))
     (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))))
+       ;; 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
@@ -407,7 +402,7 @@
                 ;; 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))))