X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=5eb5930fb0ef19e877629e873e7e41ff168c58b1;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=b3e44d3fa7d8027710e8b55b31ba97020fa73cba;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index b3e44d3..5eb5930 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -25,6 +25,13 @@
 
 (in-package "SB-PCL")
 
+;;; Ye olde CMUCL comment follows, but it seems likely that the paper
+;;; that would be inserted would resemble Kiczales and Rodruigez,
+;;; Efficient Method Dispatch in PCL, ACM 1990.  Some of the details
+;;; changed between that paper and "May Day PCL" of 1992; some other
+;;; details have changed since, but reading that paper gives the broad
+;;; idea.
+;;;
 ;;; The caching algorithm implemented:
 ;;;
 ;;; << put a paper here >>
@@ -84,7 +91,7 @@
 ;;; assembler.
 (defmacro cache-vector-ref (cache-vector location)
   `(svref (the simple-vector ,cache-vector)
-	  (sb-ext:truly-the fixnum ,location)))
+          (sb-ext:truly-the fixnum ,location)))
 
 (defmacro cache-vector-size (cache-vector)
   `(array-dimension (the simple-vector ,cache-vector) 0))
@@ -106,10 +113,10 @@
      (multiple-value-prog1
        (progn ,@body)
        (let ((old-count (cache-vector-lock-count ,cache-vector)))
-	 (declare (fixnum old-count))
-	 (setf (cache-vector-lock-count ,cache-vector)
-	       (if (= old-count most-positive-fixnum)
-		   1 (the fixnum (1+ old-count))))))))
+         (declare (fixnum old-count))
+         (setf (cache-vector-lock-count ,cache-vector)
+               (if (= old-count most-positive-fixnum)
+                   1 (the fixnum (1+ old-count))))))))
 
 (deftype field-type ()
   '(mod #.layout-clos-hash-length))
@@ -124,7 +131,7 @@
 (defconstant +nkeys-limit+ 256)
 
 (defstruct (cache (:constructor make-cache ())
-		  (:copier copy-cache-internal))
+                  (:copier copy-cache-internal))
   (owner nil)
   (nkeys 1 :type (integer 1 #.+nkeys-limit+))
   (valuep nil :type (member nil t))
@@ -148,7 +155,7 @@
 ;;; ever return a larger cache.
 (defun get-cache-vector (size)
   (flush-cache-vector-internal (make-array size)))
-  
+
 
 ;;;; wrapper cache numbers
 
@@ -219,16 +226,16 @@
     (cond
      (found
       (unless (classoid-pcl-class found)
-	(setf (classoid-pcl-class found) class))
+        (setf (classoid-pcl-class found) class))
       (aver (eq (classoid-pcl-class found) class))
       (let ((layout (classoid-layout found)))
-	(aver layout)
-	layout))
+        (aver layout)
+        layout))
      (t
       (make-wrapper-internal
        :length length
        :classoid (make-standard-classoid
-		  :name name :pcl-class class))))))
+                  :name name :pcl-class class))))))
 
 ;;; The following variable may be set to a STANDARD-CLASS that has
 ;;; already been created by the lisp code and which is to be redefined
@@ -243,32 +250,32 @@
 (defun make-wrapper (length class)
   (cond
     ((or (typep class 'std-class)
-	 (typep class 'forward-referenced-class))
+         (typep class 'forward-referenced-class))
      (make-wrapper-internal
       :length length
       :classoid
       (let ((owrap (class-wrapper class)))
-	(cond (owrap
-	       (layout-classoid owrap))
-	      ((or (*subtypep (class-of class) *the-class-standard-class*)
-		   (typep class 'forward-referenced-class))
-	       (cond ((and *pcl-class-boot*
-			   (eq (slot-value class 'name) *pcl-class-boot*))
-		      (let ((found (find-classoid
-				    (slot-value class 'name))))
-			(unless (classoid-pcl-class found)
-			  (setf (classoid-pcl-class found) class))
-			(aver (eq (classoid-pcl-class found) class))
-			found))
-		     (t
-		      (make-standard-classoid :pcl-class class))))
-	      (t
-	       (make-random-pcl-classoid :pcl-class class))))))
+        (cond (owrap
+               (layout-classoid owrap))
+              ((or (*subtypep (class-of class) *the-class-standard-class*)
+                   (typep class 'forward-referenced-class))
+               (cond ((and *pcl-class-boot*
+                           (eq (slot-value class 'name) *pcl-class-boot*))
+                      (let ((found (find-classoid
+                                    (slot-value class 'name))))
+                        (unless (classoid-pcl-class found)
+                          (setf (classoid-pcl-class found) class))
+                        (aver (eq (classoid-pcl-class found) class))
+                        found))
+                     (t
+                      (make-standard-classoid :pcl-class class))))
+              (t
+               (make-random-pcl-classoid :pcl-class class))))))
     (t
      (let* ((found (find-classoid (slot-value class 'name)))
-	    (layout (classoid-layout found)))
+            (layout (classoid-layout found)))
        (unless (classoid-pcl-class found)
-	 (setf (classoid-pcl-class found) class))
+         (setf (classoid-pcl-class found) class))
        (aver (eq (classoid-pcl-class found) class))
        (aver layout)
        layout))))
@@ -337,23 +344,23 @@
     ;; corresponds to a kind of transitivity of wrapper updates.
     (dolist (previous (gethash owrapper *previous-nwrappers*))
       (when (eq state :obsolete)
-	(setf (car previous) :obsolete))
+        (setf (car previous) :obsolete))
       (setf (cadr previous) nwrapper)
       (push previous new-previous))
 
     (let ((ocnv (wrapper-cache-number-vector owrapper)))
       (dotimes (i layout-clos-hash-length)
-	(setf (cache-number-vector-ref ocnv i) 0)))
+        (setf (cache-number-vector-ref ocnv i) 0)))
 
     (push (setf (layout-invalid owrapper) (list state nwrapper))
-	  new-previous)
+          new-previous)
 
     (setf (gethash owrapper *previous-nwrappers*) ()
-	  (gethash nwrapper *previous-nwrappers*) new-previous)))
+          (gethash nwrapper *previous-nwrappers*) new-previous)))
 
 (defun check-wrapper-validity (instance)
   (let* ((owrapper (wrapper-of instance))
-	 (state (layout-invalid owrapper)))
+         (state (layout-invalid owrapper)))
     (aver (not (eq state :uninitialized)))
     (etypecase state
       (null owrapper)
@@ -372,10 +379,10 @@
        (check-wrapper-validity instance))
       (cons
        (ecase (car state)
-	 (:flush
-	  (flush-cache-trap owrapper (cadr state) instance))
-	 (:obsolete
-	  (obsolete-instance-trap owrapper (cadr state) instance)))))))
+         (:flush
+          (flush-cache-trap owrapper (cadr state) instance))
+         (:obsolete
+          (obsolete-instance-trap owrapper (cadr state) instance)))))))
 
 (declaim (inline check-obsolete-instance))
 (defun check-obsolete-instance (instance)
@@ -387,56 +394,56 @@
   (let ((cache (make-cache)))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
-	(compute-cache-parameters nkeys valuep nlines)
+        (compute-cache-parameters nkeys valuep nlines)
       (setf (cache-nkeys cache) nkeys
-	    (cache-valuep cache) valuep
-	    (cache-nlines cache) nlines
-	    (cache-field cache) +first-wrapper-cache-number-index+
-	    (cache-limit-fn cache) limit-fn
-	    (cache-mask cache) cache-mask
-	    (cache-size cache) actual-size
-	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
-	    (cache-vector cache) (get-cache-vector actual-size)
-	    (cache-overflow cache) nil)
+            (cache-valuep cache) valuep
+            (cache-nlines cache) nlines
+            (cache-field cache) +first-wrapper-cache-number-index+
+            (cache-limit-fn cache) limit-fn
+            (cache-mask cache) cache-mask
+            (cache-size cache) actual-size
+            (cache-line-size cache) line-size
+            (cache-max-location cache) (let ((line (1- nlines)))
+                                         (if (= nkeys 1)
+                                             (* line line-size)
+                                             (1+ (* line line-size))))
+            (cache-vector cache) (get-cache-vector actual-size)
+            (cache-overflow cache) nil)
       cache)))
 
 (defun get-cache-from-cache (old-cache new-nlines
-			     &optional (new-field +first-wrapper-cache-number-index+))
+                             &optional (new-field +first-wrapper-cache-number-index+))
   (let ((nkeys (cache-nkeys old-cache))
-	(valuep (cache-valuep old-cache))
-	(cache (make-cache)))
+        (valuep (cache-valuep old-cache))
+        (cache (make-cache)))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
-	(if (= new-nlines (cache-nlines old-cache))
-	    (values (cache-mask old-cache) (cache-size old-cache)
-		    (cache-line-size old-cache) (cache-nlines old-cache))
-	    (compute-cache-parameters nkeys valuep new-nlines))
+        (if (= new-nlines (cache-nlines old-cache))
+            (values (cache-mask old-cache) (cache-size old-cache)
+                    (cache-line-size old-cache) (cache-nlines old-cache))
+            (compute-cache-parameters nkeys valuep new-nlines))
       (setf (cache-owner cache) (cache-owner old-cache)
-	    (cache-nkeys cache) nkeys
-	    (cache-valuep cache) valuep
-	    (cache-nlines cache) nlines
-	    (cache-field cache) new-field
-	    (cache-limit-fn cache) (cache-limit-fn old-cache)
-	    (cache-mask cache) cache-mask
-	    (cache-size cache) actual-size
-	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
-	    (cache-vector cache) (get-cache-vector actual-size)
-	    (cache-overflow cache) nil)
+            (cache-nkeys cache) nkeys
+            (cache-valuep cache) valuep
+            (cache-nlines cache) nlines
+            (cache-field cache) new-field
+            (cache-limit-fn cache) (cache-limit-fn old-cache)
+            (cache-mask cache) cache-mask
+            (cache-size cache) actual-size
+            (cache-line-size cache) line-size
+            (cache-max-location cache) (let ((line (1- nlines)))
+                                         (if (= nkeys 1)
+                                             (* line line-size)
+                                             (1+ (* line line-size))))
+            (cache-vector cache) (get-cache-vector actual-size)
+            (cache-overflow cache) nil)
       cache)))
 
 (defun copy-cache (old-cache)
   (let* ((new-cache (copy-cache-internal old-cache))
-	 (size (cache-size old-cache))
-	 (old-vector (cache-vector old-cache))
-	 (new-vector (get-cache-vector size)))
+         (size (cache-size old-cache))
+         (old-vector (cache-vector old-cache))
+         (new-vector (get-cache-vector size)))
     (declare (simple-vector old-vector new-vector))
     (dotimes-fixnum (i size)
       (setf (svref new-vector i) (svref old-vector i)))
@@ -451,31 +458,31 @@
   (declare (fixnum nkeys))
   (if (= nkeys 1)
       (let* ((line-size (if valuep 2 1))
-	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum
-				  (* line-size
-				     (the fixnum
-					  (power-of-two-ceiling
-					    nlines-or-cache-vector))))
-			     (cache-vector-size nlines-or-cache-vector))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-		cache-size
-		line-size
-		(the (values fixnum t) (floor cache-size line-size))))
+             (cache-size (if (typep nlines-or-cache-vector 'fixnum)
+                             (the fixnum
+                                  (* line-size
+                                     (the fixnum
+                                          (power-of-two-ceiling
+                                            nlines-or-cache-vector))))
+                             (cache-vector-size nlines-or-cache-vector))))
+        (declare (fixnum line-size cache-size))
+        (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+                cache-size
+                line-size
+                (the (values fixnum t) (floor cache-size line-size))))
       (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
-	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum
-				  (* line-size
-				     (the fixnum
-					  (power-of-two-ceiling
-					    nlines-or-cache-vector))))
-			     (1- (cache-vector-size nlines-or-cache-vector)))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-		(the fixnum (1+ cache-size))
-		line-size
-		(the (values fixnum t) (floor cache-size line-size))))))
+             (cache-size (if (typep nlines-or-cache-vector 'fixnum)
+                             (the fixnum
+                                  (* line-size
+                                     (the fixnum
+                                          (power-of-two-ceiling
+                                            nlines-or-cache-vector))))
+                             (1- (cache-vector-size nlines-or-cache-vector)))))
+        (declare (fixnum line-size cache-size))
+        (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+                (the fixnum (1+ cache-size))
+                line-size
+                (the (values fixnum t) (floor cache-size line-size))))))
 
 ;;; the various implementations of computing a primary cache location from
 ;;; wrappers. Because some implementations of this must run fast there are
@@ -494,26 +501,26 @@
   (declare (type field-type field) (fixnum mask))
   (if (not (listp wrappers))
       (logand mask
-	      (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
+              (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
       (let ((location 0) (i 0))
-	(declare (fixnum location i))
-	(dolist (wrapper wrappers)
-	  ;; First add the cache number of this wrapper to location.
-	  (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper
-								       field)))
-	    (declare (fixnum wrapper-cache-number))
-	    (if (zerop wrapper-cache-number)
-		(return-from compute-primary-cache-location 0)
-		(setq location
-		      (the fixnum (+ location wrapper-cache-number)))))
-	  ;; Then, if we are working with lots of wrappers, deal with
-	  ;; the wrapper-cache-number-mask stuff.
-	  (when (and (not (zerop i))
-		     (zerop (mod i wrapper-cache-number-adds-ok)))
-	    (setq location
-		  (logand location wrapper-cache-number-mask)))
-	  (incf i))
-	(the fixnum (1+ (logand mask location))))))
+        (declare (fixnum location i))
+        (dolist (wrapper wrappers)
+          ;; First add the cache number of this wrapper to location.
+          (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper
+                                                                       field)))
+            (declare (fixnum wrapper-cache-number))
+            (if (zerop wrapper-cache-number)
+                (return-from compute-primary-cache-location 0)
+                (setq location
+                      (the fixnum (+ location wrapper-cache-number)))))
+          ;; Then, if we are working with lots of wrappers, deal with
+          ;; the wrapper-cache-number-mask stuff.
+          (when (and (not (zerop i))
+                     (zerop (mod i wrapper-cache-number-adds-ok)))
+            (setq location
+                  (logand location wrapper-cache-number-mask)))
+          (incf i))
+        (the fixnum (1+ (logand mask location))))))
 
 ;;; This version is called on a cache line. It fetches the wrappers
 ;;; from the cache line and determines the primary location. Various
@@ -524,123 +531,121 @@
 ;;; symbol invalid to suggest to its caller that it would be provident
 ;;; to blow away the cache line in question.
 (defun compute-primary-cache-location-from-location (to-cache
-						     from-location
-						     &optional
-						     (from-cache to-cache))
+                                                     from-location
+                                                     &optional
+                                                     (from-cache to-cache))
   (declare (type cache to-cache from-cache) (fixnum from-location))
   (let ((result 0)
-	(cache-vector (cache-vector from-cache))
-	(field (cache-field to-cache))
-	(mask (cache-mask to-cache))
-	(nkeys (cache-nkeys to-cache)))
+        (cache-vector (cache-vector from-cache))
+        (field (cache-field to-cache))
+        (mask (cache-mask to-cache))
+        (nkeys (cache-nkeys to-cache)))
     (declare (type field-type field) (fixnum result mask nkeys)
-	     (simple-vector cache-vector))
+             (simple-vector cache-vector))
     (dotimes-fixnum (i nkeys)
       (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
-	     (wcn (wrapper-cache-number-vector-ref wrapper field)))
-	(declare (fixnum wcn))
-	(setq result (+ result wcn)))
+             (wcn (wrapper-cache-number-vector-ref wrapper field)))
+        (declare (fixnum wcn))
+        (setq result (+ result wcn)))
       (when (and (not (zerop i))
-		 (zerop (mod i wrapper-cache-number-adds-ok)))
-	(setq result (logand result wrapper-cache-number-mask))))
+                 (zerop (mod i wrapper-cache-number-adds-ok)))
+        (setq result (logand result wrapper-cache-number-mask))))
     (if (= nkeys 1)
-	(logand mask result)
-	(the fixnum (1+ (logand mask result))))))
+        (logand mask result)
+        (the fixnum (1+ (logand mask result))))))
 
-;;;  NIL	      means nothing so far, no actual arg info has NILs
-;;;		   in the metatype
-;;;  CLASS	    seen all sorts of metaclasses
-;;;		   (specifically, more than one of the next 4 values)
-;;;  T		means everything so far is the class T
+;;;  NIL              means nothing so far, no actual arg info has NILs
+;;;                in the metatype
+;;;  CLASS          seen all sorts of metaclasses
+;;;                (specifically, more than one of the next 4 values)
+;;;  T          means everything so far is the class T
 ;;;  STANDARD-CLASS   seen only standard classes
 ;;;  BUILT-IN-CLASS   seen only built in classes
 ;;;  STRUCTURE-CLASS  seen only structure classes
 (defun raise-metatype (metatype new-specializer)
   (let ((slot      (find-class 'slot-class))
-	(std       (find-class 'std-class))
-	(standard  (find-class 'standard-class))
-	(fsc       (find-class 'funcallable-standard-class))
-	(condition (find-class 'condition-class))
-	(structure (find-class 'structure-class))
-	(built-in  (find-class 'built-in-class)))
+        (standard  (find-class 'standard-class))
+        (fsc       (find-class 'funcallable-standard-class))
+        (condition (find-class 'condition-class))
+        (structure (find-class 'structure-class))
+        (built-in  (find-class 'built-in-class)))
     (flet ((specializer->metatype (x)
-	     (let ((meta-specializer
-		     (if (eq *boot-state* 'complete)
-			 (class-of (specializer-class x))
-			 (class-of x))))
-	       (cond
-		 ((eq x *the-class-t*) t)
-		 ((*subtypep meta-specializer std) 'standard-instance)
-		 ((*subtypep meta-specializer standard) 'standard-instance)
-		 ((*subtypep meta-specializer fsc) 'standard-instance)
-		 ((*subtypep meta-specializer condition) 'condition-instance)
-		 ((*subtypep meta-specializer structure) 'structure-instance)
-		 ((*subtypep meta-specializer built-in) 'built-in-instance)
-		 ((*subtypep meta-specializer slot) 'slot-instance)
-		 (t (error "~@<PCL cannot handle the specializer ~S ~
+             (let ((meta-specializer
+                     (if (eq *boot-state* 'complete)
+                         (class-of (specializer-class x))
+                         (class-of x))))
+               (cond
+                 ((eq x *the-class-t*) t)
+                 ((*subtypep meta-specializer standard) 'standard-instance)
+                 ((*subtypep meta-specializer fsc) 'standard-instance)
+                 ((*subtypep meta-specializer condition) 'condition-instance)
+                 ((*subtypep meta-specializer structure) 'structure-instance)
+                 ((*subtypep meta-specializer built-in) 'built-in-instance)
+                 ((*subtypep meta-specializer slot) 'slot-instance)
+                 (t (error "~@<PCL cannot handle the specializer ~S ~
                             (meta-specializer ~S).~@:>"
-			   new-specializer
-			   meta-specializer))))))
+                           new-specializer
+                           meta-specializer))))))
       ;; We implement the following table. The notation is
       ;; that X and Y are distinct meta specializer names.
       ;;
       ;;   NIL    <anything>    ===>  <anything>
-      ;;    X      X	    ===>      X
-      ;;    X      Y	    ===>    CLASS
+      ;;    X      X        ===>      X
+      ;;    X      Y        ===>    CLASS
       (let ((new-metatype (specializer->metatype new-specializer)))
-	(cond ((eq new-metatype 'slot-instance) 'class)
-	      ((null metatype) new-metatype)
-	      ((eq metatype new-metatype) new-metatype)
-	      (t 'class))))))
+        (cond ((eq new-metatype 'slot-instance) 'class)
+              ((null metatype) new-metatype)
+              ((eq metatype new-metatype) new-metatype)
+              (t 'class))))))
 
 (defmacro with-dfun-wrappers ((args metatypes)
-			      (dfun-wrappers invalid-wrapper-p
-					     &optional wrappers classes types)
-			      invalid-arguments-form
-			      &body body)
+                              (dfun-wrappers invalid-wrapper-p
+                                             &optional wrappers classes types)
+                              invalid-arguments-form
+                              &body body)
   `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
-	  (,dfun-wrappers nil) (dfun-wrappers-tail nil)
-	  ,@(when wrappers
-	      `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
+          (,dfun-wrappers nil) (dfun-wrappers-tail nil)
+          ,@(when wrappers
+              `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
      (dolist (mt ,metatypes)
        (unless args-tail
-	 (setq invalid-arguments-p t)
-	 (return nil))
+         (setq invalid-arguments-p t)
+         (return nil))
        (let* ((arg (pop args-tail))
-	      (wrapper nil)
-	      ,@(when wrappers
-		  `((class *the-class-t*)
-		    (type t))))
-	 (unless (eq mt t)
-	   (setq wrapper (wrapper-of arg))
-	   (when (invalid-wrapper-p wrapper)
-	     (setq ,invalid-wrapper-p t)
-	     (setq wrapper (check-wrapper-validity arg)))
-	   (cond ((null ,dfun-wrappers)
-		  (setq ,dfun-wrappers wrapper))
-		 ((not (consp ,dfun-wrappers))
-		  (setq dfun-wrappers-tail (list wrapper))
-		  (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
-		 (t
-		  (let ((new-dfun-wrappers-tail (list wrapper)))
-		    (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
-		    (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
-	   ,@(when wrappers
-	       `((setq class (wrapper-class* wrapper))
-		 (setq type `(class-eq ,class)))))
-	 ,@(when wrappers
-	     `((push wrapper wrappers-rev)
-	       (push class classes-rev)
-	       (push type types-rev)))))
+              (wrapper nil)
+              ,@(when wrappers
+                  `((class *the-class-t*)
+                    (type t))))
+         (unless (eq mt t)
+           (setq wrapper (wrapper-of arg))
+           (when (invalid-wrapper-p wrapper)
+             (setq ,invalid-wrapper-p t)
+             (setq wrapper (check-wrapper-validity arg)))
+           (cond ((null ,dfun-wrappers)
+                  (setq ,dfun-wrappers wrapper))
+                 ((not (consp ,dfun-wrappers))
+                  (setq dfun-wrappers-tail (list wrapper))
+                  (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
+                 (t
+                  (let ((new-dfun-wrappers-tail (list wrapper)))
+                    (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
+                    (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
+           ,@(when wrappers
+               `((setq class (wrapper-class* wrapper))
+                 (setq type `(class-eq ,class)))))
+         ,@(when wrappers
+             `((push wrapper wrappers-rev)
+               (push class classes-rev)
+               (push type types-rev)))))
      (if invalid-arguments-p
-	 ,invalid-arguments-form
-	 (let* (,@(when wrappers
-		    `((,wrappers (nreverse wrappers-rev))
-		      (,classes (nreverse classes-rev))
-		      (,types (mapcar (lambda (class)
-					`(class-eq ,class))
-				      ,classes)))))
-	   ,@body))))
+         ,invalid-arguments-form
+         (let* (,@(when wrappers
+                    `((,wrappers (nreverse wrappers-rev))
+                      (,classes (nreverse classes-rev))
+                      (,types (mapcar (lambda (class)
+                                        `(class-eq ,class))
+                                      ,classes)))))
+           ,@body))))
 
 ;;;; some support stuff for getting a hold of symbols that we need when
 ;;;; building the discriminator codes. It's OK for these to be interned
@@ -703,8 +708,8 @@
              (push (dfun-arg-symbol i) required))
            (nreverse required))))
     `(,(if (eq emf-type 'fast-method-call)
-	   'invoke-effective-method-function-fast
-	   'invoke-effective-method-function)
+           'invoke-effective-method-function-fast
+           'invoke-effective-method-function)
       ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
 
 (defun make-fast-method-call-lambda-list (metatypes applyp)
@@ -721,202 +726,202 @@
   `(let ((.cache. ,cache))
      (declare (type cache .cache.))
      (labels ((cache () .cache.)
-	      (nkeys () (cache-nkeys .cache.))
-	      (line-size () (cache-line-size .cache.))
-	      (vector () (cache-vector .cache.))
-	      (valuep () (cache-valuep .cache.))
-	      (nlines () (cache-nlines .cache.))
-	      (max-location () (cache-max-location .cache.))
-	      (limit-fn () (cache-limit-fn .cache.))
-	      (size () (cache-size .cache.))
-	      (mask () (cache-mask .cache.))
-	      (field () (cache-field .cache.))
-	      (overflow () (cache-overflow .cache.))
-	      ;;
-	      ;; Return T IFF this cache location is reserved.  The
-	      ;; only time this is true is for line number 0 of an
-	      ;; nkeys=1 cache.
-	      ;;
-	      (line-reserved-p (line)
-		(declare (fixnum line))
-		(and (= (nkeys) 1)
-		     (= line 0)))
-	      ;;
-	      (location-reserved-p (location)
-		(declare (fixnum location))
-		(and (= (nkeys) 1)
-		     (= location 0)))
-	      ;;
-	      ;; Given a line number, return the cache location.
-	      ;; This is the value that is the second argument to
-	      ;; cache-vector-ref.  Basically, this deals with the
-	      ;; offset of nkeys>1 caches and multiplies by line
-	      ;; size.
-	      ;; 	  
-	      (line-location (line)
-		(declare (fixnum line))
-		(when (line-reserved-p line)
-		  (error "line is reserved"))
-		(if (= (nkeys) 1)
-		    (the fixnum (* line (line-size)))
-		    (the fixnum (1+ (the fixnum (* line (line-size)))))))
-	      ;;
-	      ;; Given a cache location, return the line.  This is
-	      ;; the inverse of LINE-LOCATION.
-	      ;; 	  
-	      (location-line (location)
-		(declare (fixnum location))
-		(if (= (nkeys) 1)
-		    (floor location (line-size))
-		    (floor (the fixnum (1- location)) (line-size))))
-	      ;;
-	      ;; Given a line number, return the wrappers stored at
-	      ;; that line.  As usual, if nkeys=1, this returns a
-	      ;; single value.  Only when nkeys>1 does it return a
-	      ;; list.  An error is signalled if the line is
-	      ;; reserved.
-	      ;;
-	      (line-wrappers (line)
-		(declare (fixnum line))
-		(when (line-reserved-p line) (error "Line is reserved."))
-		(location-wrappers (line-location line)))
-	      ;;
-	      (location-wrappers (location) ; avoid multiplies caused by line-location
-		(declare (fixnum location))
-		(if (= (nkeys) 1)
-		    (cache-vector-ref (vector) location)
-		    (let ((list (make-list (nkeys)))
-			  (vector (vector)))
-		      (declare (simple-vector vector))
-		      (dotimes (i (nkeys) list)
-			(declare (fixnum i))
-			(setf (nth i list)
-			      (cache-vector-ref vector (+ location i)))))))
-	      ;;
-	      ;; Given a line number, return true IFF the line's
-	      ;; wrappers are the same as wrappers.
-	      ;;
-	      (line-matches-wrappers-p (line wrappers)
-		(declare (fixnum line))
-		(and (not (line-reserved-p line))
-		     (location-matches-wrappers-p (line-location line)
-						  wrappers)))
-	      ;;
-	      (location-matches-wrappers-p (loc wrappers) ; must not be reserved
-		(declare (fixnum loc))
-		(let ((cache-vector (vector)))
-		  (declare (simple-vector cache-vector))
-		  (if (= (nkeys) 1)
-		      (eq wrappers (cache-vector-ref cache-vector loc))
-		      (dotimes (i (nkeys) t)
-			(declare (fixnum i))
-			(unless (eq (pop wrappers)
-				    (cache-vector-ref cache-vector (+ loc i)))
-			  (return nil))))))
-	      ;;
-	      ;; Given a line number, return the value stored at that line.
-	      ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
-	      ;; an error is signalled if the line is reserved.
-	      ;; 
-	      (line-value (line)
-		(declare (fixnum line))
-		(when (line-reserved-p line) (error "Line is reserved."))
-		(location-value (line-location line)))
-	      ;;
-	      (location-value (loc)
-		(declare (fixnum loc))
-		(and (valuep)
-		     (cache-vector-ref (vector) (+ loc (nkeys)))))
-	      ;;
-	      ;; Given a line number, return true IFF that line has data in
-	      ;; it.  The state of the wrappers stored in the line is not
-	      ;; checked.  An error is signalled if line is reserved.
-	      (line-full-p (line)
-		(when (line-reserved-p line) (error "Line is reserved."))
-		(not (null (cache-vector-ref (vector) (line-location line)))))
-	      ;;
-	      ;; Given a line number, return true IFF the line is full and
-	      ;; there are no invalid wrappers in the line, and the line's
-	      ;; wrappers are different from wrappers.
-	      ;; An error is signalled if the line is reserved.
-	      ;;
-	      (line-valid-p (line wrappers)
-		(declare (fixnum line))
-		(when (line-reserved-p line) (error "Line is reserved."))
-		(location-valid-p (line-location line) wrappers))
-	      ;;
-	      (location-valid-p (loc wrappers)
-		(declare (fixnum loc))
-		(let ((cache-vector (vector))
-		      (wrappers-mismatch-p (null wrappers)))
-		  (declare (simple-vector cache-vector))
-		  (dotimes (i (nkeys) wrappers-mismatch-p)
-		    (declare (fixnum i))
-		    (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
-		      (when (or (null wrapper)
-				(invalid-wrapper-p wrapper))
-			(return nil))
-		      (unless (and wrappers
-				   (eq wrapper
-				       (if (consp wrappers)
-					   (pop wrappers)
-					   wrappers)))
-			(setq wrappers-mismatch-p t))))))
-	      ;;
-	      ;; How many unreserved lines separate line-1 and line-2.
-	      ;;
-	      (line-separation (line-1 line-2)
-		(declare (fixnum line-1 line-2))
-		(let ((diff (the fixnum (- line-2 line-1))))
-		  (declare (fixnum diff))
-		  (when (minusp diff)
-		    (setq diff (+ diff (nlines)))
-		    (when (line-reserved-p 0)
-		      (setq diff (1- diff))))
-		  diff))
-	      ;;
-	      ;; Given a cache line, get the next cache line.  This will not
-	      ;; return a reserved line.
-	      ;; 
-	      (next-line (line)
-		(declare (fixnum line))
-		(if (= line (the fixnum (1- (nlines))))
-		    (if (line-reserved-p 0) 1 0)
-		    (the fixnum (1+ line))))
-	      ;;
-	      (next-location (loc)
-		(declare (fixnum loc))
-		(if (= loc (max-location))
-		    (if (= (nkeys) 1)
-			(line-size)
-			1)
-		    (the fixnum (+ loc (line-size)))))
-	      ;;
-	      ;; Given a line which has a valid entry in it, this
-	      ;; will return the primary cache line of the wrappers
-	      ;; in that line.  We just call
-	      ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this
-	      ;; is an easier packaging up of the call to it.
-	      ;; 
-	      (line-primary (line)
-		(declare (fixnum line))
-		(location-line (line-primary-location line)))
-	      ;;
-	      (line-primary-location (line)
-		(declare (fixnum line))
-		(compute-primary-cache-location-from-location
-		 (cache) (line-location line))))
+              (nkeys () (cache-nkeys .cache.))
+              (line-size () (cache-line-size .cache.))
+              (vector () (cache-vector .cache.))
+              (valuep () (cache-valuep .cache.))
+              (nlines () (cache-nlines .cache.))
+              (max-location () (cache-max-location .cache.))
+              (limit-fn () (cache-limit-fn .cache.))
+              (size () (cache-size .cache.))
+              (mask () (cache-mask .cache.))
+              (field () (cache-field .cache.))
+              (overflow () (cache-overflow .cache.))
+              ;;
+              ;; Return T IFF this cache location is reserved.  The
+              ;; only time this is true is for line number 0 of an
+              ;; nkeys=1 cache.
+              ;;
+              (line-reserved-p (line)
+                (declare (fixnum line))
+                (and (= (nkeys) 1)
+                     (= line 0)))
+              ;;
+              (location-reserved-p (location)
+                (declare (fixnum location))
+                (and (= (nkeys) 1)
+                     (= location 0)))
+              ;;
+              ;; Given a line number, return the cache location.
+              ;; This is the value that is the second argument to
+              ;; cache-vector-ref.  Basically, this deals with the
+              ;; offset of nkeys>1 caches and multiplies by line
+              ;; size.
+              ;;
+              (line-location (line)
+                (declare (fixnum line))
+                (when (line-reserved-p line)
+                  (error "line is reserved"))
+                (if (= (nkeys) 1)
+                    (the fixnum (* line (line-size)))
+                    (the fixnum (1+ (the fixnum (* line (line-size)))))))
+              ;;
+              ;; Given a cache location, return the line.  This is
+              ;; the inverse of LINE-LOCATION.
+              ;;
+              (location-line (location)
+                (declare (fixnum location))
+                (if (= (nkeys) 1)
+                    (floor location (line-size))
+                    (floor (the fixnum (1- location)) (line-size))))
+              ;;
+              ;; Given a line number, return the wrappers stored at
+              ;; that line.  As usual, if nkeys=1, this returns a
+              ;; single value.  Only when nkeys>1 does it return a
+              ;; list.  An error is signalled if the line is
+              ;; reserved.
+              ;;
+              (line-wrappers (line)
+                (declare (fixnum line))
+                (when (line-reserved-p line) (error "Line is reserved."))
+                (location-wrappers (line-location line)))
+              ;;
+              (location-wrappers (location) ; avoid multiplies caused by line-location
+                (declare (fixnum location))
+                (if (= (nkeys) 1)
+                    (cache-vector-ref (vector) location)
+                    (let ((list (make-list (nkeys)))
+                          (vector (vector)))
+                      (declare (simple-vector vector))
+                      (dotimes (i (nkeys) list)
+                        (declare (fixnum i))
+                        (setf (nth i list)
+                              (cache-vector-ref vector (+ location i)))))))
+              ;;
+              ;; Given a line number, return true IFF the line's
+              ;; wrappers are the same as wrappers.
+              ;;
+              (line-matches-wrappers-p (line wrappers)
+                (declare (fixnum line))
+                (and (not (line-reserved-p line))
+                     (location-matches-wrappers-p (line-location line)
+                                                  wrappers)))
+              ;;
+              (location-matches-wrappers-p (loc wrappers) ; must not be reserved
+                (declare (fixnum loc))
+                (let ((cache-vector (vector)))
+                  (declare (simple-vector cache-vector))
+                  (if (= (nkeys) 1)
+                      (eq wrappers (cache-vector-ref cache-vector loc))
+                      (dotimes (i (nkeys) t)
+                        (declare (fixnum i))
+                        (unless (eq (pop wrappers)
+                                    (cache-vector-ref cache-vector (+ loc i)))
+                          (return nil))))))
+              ;;
+              ;; Given a line number, return the value stored at that line.
+              ;; If valuep is NIL, this returns NIL.  As with line-wrappers,
+              ;; an error is signalled if the line is reserved.
+              ;;
+              (line-value (line)
+                (declare (fixnum line))
+                (when (line-reserved-p line) (error "Line is reserved."))
+                (location-value (line-location line)))
+              ;;
+              (location-value (loc)
+                (declare (fixnum loc))
+                (and (valuep)
+                     (cache-vector-ref (vector) (+ loc (nkeys)))))
+              ;;
+              ;; Given a line number, return true IFF that line has data in
+              ;; it.  The state of the wrappers stored in the line is not
+              ;; checked.  An error is signalled if line is reserved.
+              (line-full-p (line)
+                (when (line-reserved-p line) (error "Line is reserved."))
+                (not (null (cache-vector-ref (vector) (line-location line)))))
+              ;;
+              ;; Given a line number, return true IFF the line is full and
+              ;; there are no invalid wrappers in the line, and the line's
+              ;; wrappers are different from wrappers.
+              ;; An error is signalled if the line is reserved.
+              ;;
+              (line-valid-p (line wrappers)
+                (declare (fixnum line))
+                (when (line-reserved-p line) (error "Line is reserved."))
+                (location-valid-p (line-location line) wrappers))
+              ;;
+              (location-valid-p (loc wrappers)
+                (declare (fixnum loc))
+                (let ((cache-vector (vector))
+                      (wrappers-mismatch-p (null wrappers)))
+                  (declare (simple-vector cache-vector))
+                  (dotimes (i (nkeys) wrappers-mismatch-p)
+                    (declare (fixnum i))
+                    (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
+                      (when (or (null wrapper)
+                                (invalid-wrapper-p wrapper))
+                        (return nil))
+                      (unless (and wrappers
+                                   (eq wrapper
+                                       (if (consp wrappers)
+                                           (pop wrappers)
+                                           wrappers)))
+                        (setq wrappers-mismatch-p t))))))
+              ;;
+              ;; How many unreserved lines separate line-1 and line-2.
+              ;;
+              (line-separation (line-1 line-2)
+                (declare (fixnum line-1 line-2))
+                (let ((diff (the fixnum (- line-2 line-1))))
+                  (declare (fixnum diff))
+                  (when (minusp diff)
+                    (setq diff (+ diff (nlines)))
+                    (when (line-reserved-p 0)
+                      (setq diff (1- diff))))
+                  diff))
+              ;;
+              ;; Given a cache line, get the next cache line.  This will not
+              ;; return a reserved line.
+              ;;
+              (next-line (line)
+                (declare (fixnum line))
+                (if (= line (the fixnum (1- (nlines))))
+                    (if (line-reserved-p 0) 1 0)
+                    (the fixnum (1+ line))))
+              ;;
+              (next-location (loc)
+                (declare (fixnum loc))
+                (if (= loc (max-location))
+                    (if (= (nkeys) 1)
+                        (line-size)
+                        1)
+                    (the fixnum (+ loc (line-size)))))
+              ;;
+              ;; Given a line which has a valid entry in it, this
+              ;; will return the primary cache line of the wrappers
+              ;; in that line.  We just call
+              ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this
+              ;; is an easier packaging up of the call to it.
+              ;;
+              (line-primary (line)
+                (declare (fixnum line))
+                (location-line (line-primary-location line)))
+              ;;
+              (line-primary-location (line)
+                (declare (fixnum line))
+                (compute-primary-cache-location-from-location
+                 (cache) (line-location line))))
        (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep
-			   #'nlines #'max-location #'limit-fn #'size
-			   #'mask #'field #'overflow #'line-reserved-p
-			   #'location-reserved-p #'line-location
-			   #'location-line #'line-wrappers #'location-wrappers
-			   #'line-matches-wrappers-p
-			   #'location-matches-wrappers-p
-			   #'line-value #'location-value #'line-full-p
-			   #'line-valid-p #'location-valid-p
-			   #'line-separation #'next-line #'next-location
-			   #'line-primary #'line-primary-location))
+                           #'nlines #'max-location #'limit-fn #'size
+                           #'mask #'field #'overflow #'line-reserved-p
+                           #'location-reserved-p #'line-location
+                           #'location-line #'line-wrappers #'location-wrappers
+                           #'line-matches-wrappers-p
+                           #'location-matches-wrappers-p
+                           #'line-value #'location-value #'line-full-p
+                           #'line-valid-p #'location-valid-p
+                           #'line-separation #'next-line #'next-location
+                           #'line-primary #'line-primary-location))
        ,@body)))
 
 ;;; Here is where we actually fill, recache and expand caches.
@@ -938,14 +943,14 @@
 
 (defun fill-cache (cache wrappers value)
   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
-  (assert wrappers)
+  (aver wrappers)
 
   (or (fill-cache-p nil cache wrappers value)
-      (and (< (ceiling (* (cache-count cache) 1.25))
-	      (if (= (cache-nkeys cache) 1)
-		  (1- (cache-nlines cache))
-		  (cache-nlines cache)))
-	   (adjust-cache cache wrappers value))
+      (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
+              (if (= (cache-nkeys cache) 1)
+                  (1- (cache-nlines cache))
+                  (cache-nlines cache)))
+           (adjust-cache cache wrappers value))
       (expand-cache cache wrappers value)))
 
 (defvar *check-cache-p* nil)
@@ -959,58 +964,55 @@
 (defun check-cache (cache)
   (with-local-cache-functions (cache)
     (let ((location (if (= (nkeys) 1) 0 1))
-	  (limit (funcall (limit-fn) (nlines))))
+          (limit (funcall (limit-fn) (nlines))))
       (dotimes-fixnum (i (nlines) cache)
-	(when (and (not (location-reserved-p location))
-		   (line-full-p i))
-	  (let* ((home-loc (compute-primary-cache-location-from-location
-			    cache location))
-		 (home (location-line (if (location-reserved-p home-loc)
-					  (next-location home-loc)
-					  home-loc)))
-		 (sep (when home (line-separation home i))))
-	    (when (and sep (> sep limit))
-	      (error "bad cache ~S ~@
-		      value at location ~W: ~W lines from its home. The limit is ~W."
-		     cache location sep limit))))
-	(setq location (next-location location))))))
+        (when (and (not (location-reserved-p location))
+                   (line-full-p i))
+          (let* ((home-loc (compute-primary-cache-location-from-location
+                            cache location))
+                 (home (location-line (if (location-reserved-p home-loc)
+                                          (next-location home-loc)
+                                          home-loc)))
+                 (sep (when home (line-separation home i))))
+            (when (and sep (> sep limit))
+              (error "bad cache ~S ~@
+                      value at location ~W: ~W lines from its home. The limit is ~W."
+                     cache location sep limit))))
+        (setq location (next-location location))))))
 
 (defun probe-cache (cache wrappers &optional default limit-fn)
   ;;(declare (values value))
-  (unless wrappers
-    ;; FIXME: This and another earlier test on a WRAPPERS arg can
-    ;; be compact assertoids.
-    (error "WRAPPERS arg is NIL!"))
+  (aver wrappers)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
-	   (limit (funcall (or limit-fn (limit-fn)) (nlines))))
+           (limit (funcall (or limit-fn (limit-fn)) (nlines))))
       (declare (fixnum location limit))
       (when (location-reserved-p location)
-	(setq location (next-location location)))
+        (setq location (next-location location)))
       (dotimes-fixnum (i (1+ limit))
-	(when (location-matches-wrappers-p location wrappers)
-	  (return-from probe-cache (or (not (valuep))
-				       (location-value location))))
-	(setq location (next-location location)))
+        (when (location-matches-wrappers-p location wrappers)
+          (return-from probe-cache (or (not (valuep))
+                                       (location-value location))))
+        (setq location (next-location location)))
       (dolist (entry (overflow))
-	(when (equal (car entry) wrappers)
-	  (return-from probe-cache (or (not (valuep))
-				       (cdr entry)))))
+        (when (equal (car entry) wrappers)
+          (return-from probe-cache (or (not (valuep))
+                                       (cdr entry)))))
       default)))
 
 (defun map-cache (function cache &optional set-p)
   (with-local-cache-functions (cache)
     (let ((set-p (and set-p (valuep))))
       (dotimes-fixnum (i (nlines) cache)
-	(unless (or (line-reserved-p i) (not (line-valid-p i nil)))
-	  (let ((value (funcall function (line-wrappers i) (line-value i))))
-	    (when set-p
-	      (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
-		    value)))))
+        (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
+          (let ((value (funcall function (line-wrappers i) (line-value i))))
+            (when set-p
+              (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
+                    value)))))
       (dolist (entry (overflow))
-	(let ((value (funcall function (car entry) (cdr entry))))
-	  (when set-p
-	    (setf (cdr entry) value))))))
+        (let ((value (funcall function (car entry) (cdr entry))))
+          (when set-p
+            (setf (cdr entry) value))))))
   cache)
 
 (defun cache-count (cache)
@@ -1018,83 +1020,90 @@
     (let ((count 0))
       (declare (fixnum count))
       (dotimes-fixnum (i (nlines) count)
-	(unless (line-reserved-p i)
-	  (when (line-full-p i)
-	    (incf count)))))))
+        (unless (line-reserved-p i)
+          (when (line-full-p i)
+            (incf count)))))))
 
 (defun entry-in-cache-p (cache wrappers value)
   (declare (ignore value))
   (with-local-cache-functions (cache)
     (dotimes-fixnum (i (nlines))
       (unless (line-reserved-p i)
-	(when (equal (line-wrappers i) wrappers)
-	  (return t))))))
+        (when (equal (line-wrappers i) wrappers)
+          (return t))))))
 
 ;;; returns T or NIL
 (defun fill-cache-p (forcep cache wrappers value)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
-	   (primary (location-line location)))
+           (primary (location-line location)))
       (declare (fixnum location primary))
+      ;; FIXME: I tried (aver (> location 0)) and (aver (not
+      ;; (location-reserved-p location))) here, on the basis that
+      ;; particularly passing a LOCATION of 0 for a cache with more
+      ;; than one key would cause PRIMARY to be -1.  However, the
+      ;; AVERs triggered during the bootstrap, and removing them
+      ;; didn't cause anything to break, so I've left them removed.
+      ;; I'm still confused as to what is right.  -- CSR, 2006-04-20
       (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary cache wrappers)
-	(when (or forcep emptyp)
-	  (when (not emptyp)
-	    (push (cons (line-wrappers free) (line-value free))
-		  (cache-overflow cache)))
-	  ;;(fill-line free wrappers value)
-	  (let ((line free))
-	    (declare (fixnum line))
-	    (when (line-reserved-p line)
-	      (error "attempt to fill a reserved line"))
-	    (let ((loc (line-location line))
-		  (cache-vector (vector)))
-	      (declare (fixnum loc) (simple-vector cache-vector))
-	      (cond ((= (nkeys) 1)
-		     (setf (cache-vector-ref cache-vector loc) wrappers)
-		     (when (valuep)
-		       (setf (cache-vector-ref cache-vector (1+ loc)) value)))
-		    (t
-		     (let ((i 0))
-		       (declare (fixnum i))
-		       (dolist (w wrappers)
-			 (setf (cache-vector-ref cache-vector (+ loc i)) w)
-			 (setq i (the fixnum (1+ i)))))
-		     (when (valuep)
-		       (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
-			     value))))
-	      (maybe-check-cache cache))))))))
+          (find-free-cache-line primary cache wrappers)
+        (when (or forcep emptyp)
+          (when (not emptyp)
+            (push (cons (line-wrappers free) (line-value free))
+                  (cache-overflow cache)))
+          ;;(fill-line free wrappers value)
+          (let ((line free))
+            (declare (fixnum line))
+            (when (line-reserved-p line)
+              (error "attempt to fill a reserved line"))
+            (let ((loc (line-location line))
+                  (cache-vector (vector)))
+              (declare (fixnum loc) (simple-vector cache-vector))
+              (cond ((= (nkeys) 1)
+                     (setf (cache-vector-ref cache-vector loc) wrappers)
+                     (when (valuep)
+                       (setf (cache-vector-ref cache-vector (1+ loc)) value)))
+                    (t
+                     (let ((i 0))
+                       (declare (fixnum i))
+                       (dolist (w wrappers)
+                         (setf (cache-vector-ref cache-vector (+ loc i)) w)
+                         (setq i (the fixnum (1+ i)))))
+                     (when (valuep)
+                       (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
+                             value))))
+              (maybe-check-cache cache))))))))
 
 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
   (declare (fixnum from-line))
   (with-local-cache-functions (cache)
     (let ((primary (location-line
-		    (compute-primary-cache-location-from-location
-		     cache (line-location from-line) from-cache))))
+                    (compute-primary-cache-location-from-location
+                     cache (line-location from-line) from-cache))))
       (declare (fixnum primary))
       (multiple-value-bind (free emptyp)
-	  (find-free-cache-line primary cache)
-	(when (or forcep emptyp)
-	  (when (not emptyp)
-	    (push (cons (line-wrappers free) (line-value free))
-		  (cache-overflow cache)))
-	  ;;(transfer-line from-cache-vector from-line cache-vector free)
-	  (let ((from-cache-vector (cache-vector from-cache))
-		(to-cache-vector (vector))
-		(to-line free))
-	    (declare (fixnum to-line))
-	    (if (line-reserved-p to-line)
-		(error "transferring something into a reserved cache line")
-		(let ((from-loc (line-location from-line))
-		      (to-loc (line-location to-line)))
-		  (declare (fixnum from-loc to-loc))
-		  (modify-cache to-cache-vector
-				(dotimes-fixnum (i (line-size))
-				  (setf (cache-vector-ref to-cache-vector
-							  (+ to-loc i))
-					(cache-vector-ref from-cache-vector
-							  (+ from-loc i)))))))
-	    (maybe-check-cache cache)))))))
+          (find-free-cache-line primary cache)
+        (when (or forcep emptyp)
+          (when (not emptyp)
+            (push (cons (line-wrappers free) (line-value free))
+                  (cache-overflow cache)))
+          ;;(transfer-line from-cache-vector from-line cache-vector free)
+          (let ((from-cache-vector (cache-vector from-cache))
+                (to-cache-vector (vector))
+                (to-line free))
+            (declare (fixnum to-line))
+            (if (line-reserved-p to-line)
+                (error "transferring something into a reserved cache line")
+                (let ((from-loc (line-location from-line))
+                      (to-loc (line-location to-line)))
+                  (declare (fixnum from-loc to-loc))
+                  (modify-cache to-cache-vector
+                                (dotimes-fixnum (i (line-size))
+                                  (setf (cache-vector-ref to-cache-vector
+                                                          (+ to-loc i))
+                                        (cache-vector-ref from-cache-vector
+                                                          (+ from-loc i)))))))
+            (maybe-check-cache cache)))))))
 
 ;;; Returns NIL or (values <field> <cache-vector>)
 ;;;
@@ -1109,23 +1118,23 @@
   (with-local-cache-functions (cache)
     (let ((ncache (get-cache-from-cache cache (nlines) (field))))
       (do ((nfield (cache-field ncache)
-		   (next-wrapper-cache-number-index nfield)))
-	  ((null nfield) nil)
-	(setf (cache-field ncache) nfield)
-	(labels ((try-one-fill-from-line (line)
-		   (fill-cache-from-cache-p nil ncache cache line))
-		 (try-one-fill (wrappers value)
-		   (fill-cache-p nil ncache wrappers value)))
-	  (if (and (dotimes-fixnum (i (nlines) t)
-		     (when (and (null (line-reserved-p i))
-				(line-valid-p i wrappers))
-		       (unless (try-one-fill-from-line i) (return nil))))
-		   (dolist (wrappers+value (cache-overflow cache) t)
-		     (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
-		       (return nil)))
-		   (try-one-fill wrappers value))
-	      (return (maybe-check-cache ncache))
-	      (flush-cache-vector-internal (cache-vector ncache))))))))
+                   (next-wrapper-cache-number-index nfield)))
+          ((null nfield) nil)
+        (setf (cache-field ncache) nfield)
+        (labels ((try-one-fill-from-line (line)
+                   (fill-cache-from-cache-p nil ncache cache line))
+                 (try-one-fill (wrappers value)
+                   (fill-cache-p nil ncache wrappers value)))
+          (if (and (dotimes-fixnum (i (nlines) t)
+                     (when (and (null (line-reserved-p i))
+                                (line-valid-p i wrappers))
+                       (unless (try-one-fill-from-line i) (return nil))))
+                   (dolist (wrappers+value (cache-overflow cache) t)
+                     (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+                       (return nil)))
+                   (try-one-fill wrappers value))
+              (return (maybe-check-cache ncache))
+              (flush-cache-vector-internal (cache-vector ncache))))))))
 
 ;;; returns: (values <cache>)
 (defun expand-cache (cache wrappers value)
@@ -1133,91 +1142,94 @@
   (with-local-cache-functions (cache)
     (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
       (labels ((do-one-fill-from-line (line)
-		 (unless (fill-cache-from-cache-p nil ncache cache line)
-		   (do-one-fill (line-wrappers line) (line-value line))))
-	       (do-one-fill (wrappers value)
-		 (setq ncache (or (adjust-cache ncache wrappers value)
-				  (fill-cache-p t ncache wrappers value))))
-	       (try-one-fill (wrappers value)
-		 (fill-cache-p nil ncache wrappers value)))
-	(dotimes-fixnum (i (nlines))
-	  (when (and (null (line-reserved-p i))
-		     (line-valid-p i wrappers))
-	    (do-one-fill-from-line i)))
-	(dolist (wrappers+value (cache-overflow cache))
-	  (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
-	    (do-one-fill (car wrappers+value) (cdr wrappers+value))))
-	(unless (try-one-fill wrappers value)
-	  (do-one-fill wrappers value))
-	(maybe-check-cache ncache)))))
+                 (unless (fill-cache-from-cache-p nil ncache cache line)
+                   (do-one-fill (line-wrappers line) (line-value line))))
+               (do-one-fill (wrappers value)
+                 (setq ncache (or (adjust-cache ncache wrappers value)
+                                  (fill-cache-p t ncache wrappers value))))
+               (try-one-fill (wrappers value)
+                 (fill-cache-p nil ncache wrappers value)))
+        (dotimes-fixnum (i (nlines))
+          (when (and (null (line-reserved-p i))
+                     (line-valid-p i wrappers))
+            (do-one-fill-from-line i)))
+        (dolist (wrappers+value (cache-overflow cache))
+          (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+            (do-one-fill (car wrappers+value) (cdr wrappers+value))))
+        (unless (try-one-fill wrappers value)
+          (do-one-fill wrappers value))
+        (maybe-check-cache ncache)))))
 
+(defvar *pcl-misc-random-state* (make-random-state))
+
 ;;; This is the heart of the cache filling mechanism. It implements
 ;;; the decisions about where entries are placed.
 ;;;
 ;;; Find a line in the cache at which a new entry can be inserted.
 ;;;
 ;;;   <line>
-;;;   <empty?>	   is <line> in fact empty?
+;;;   <empty?>     is <line> in fact empty?
 (defun find-free-cache-line (primary cache &optional wrappers)
   ;;(declare (values line empty?))
   (declare (fixnum primary))
   (with-local-cache-functions (cache)
     (when (line-reserved-p primary) (setq primary (next-line primary)))
     (let ((limit (funcall (limit-fn) (nlines)))
-	  (wrappedp nil)
-	  (lines nil)
-	  (p primary) (s primary))
+          (wrappedp nil)
+          (lines nil)
+          (p primary) (s primary))
       (declare (fixnum p s limit))
       (block find-free
-	(loop
-	 ;; Try to find a free line starting at <s>. <p> is the
-	 ;; primary line of the entry we are finding a free
-	 ;; line for, it is used to compute the separations.
-	 (do* ((line s (next-line line))
-	       (nsep (line-separation p s) (1+ nsep)))
-	      (())
-	   (declare (fixnum line nsep))
-	   (when (null (line-valid-p line wrappers)) ;If this line is empty or
-	     (push line lines)		;invalid, just use it.
-	     (return-from find-free))
-	   (when (and wrappedp (>= line primary))
-	     ;; have gone all the way around the cache, time to quit
-	     (return-from find-free-cache-line (values primary nil)))
-	   (let ((osep (line-separation (line-primary line) line)))
-	     (when (>= osep limit)
-	       (return-from find-free-cache-line (values primary nil)))
-	     (when (cond ((= nsep limit) t)
-			 ((= nsep osep) (zerop (random 2)))
-			 ((> nsep osep) t)
-			 (t nil))
-	       ;; See whether we can displace what is in this line so that we
-	       ;; can use the line.
-	       (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
-	       (setq p (line-primary line))
-	       (setq s (next-line line))
-	       (push line lines)
-	       (return nil)))
-	   (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
+        (loop
+         ;; Try to find a free line starting at <s>. <p> is the
+         ;; primary line of the entry we are finding a free
+         ;; line for, it is used to compute the separations.
+         (do* ((line s (next-line line))
+               (nsep (line-separation p s) (1+ nsep)))
+              (())
+           (declare (fixnum line nsep))
+           (when (null (line-valid-p line wrappers)) ;If this line is empty or
+             (push line lines)          ;invalid, just use it.
+             (return-from find-free))
+           (when (and wrappedp (>= line primary))
+             ;; have gone all the way around the cache, time to quit
+             (return-from find-free-cache-line (values primary nil)))
+           (let ((osep (line-separation (line-primary line) line)))
+             (when (>= osep limit)
+               (return-from find-free-cache-line (values primary nil)))
+             (when (cond ((= nsep limit) t)
+                         ((= nsep osep)
+                          (zerop (random 2 *pcl-misc-random-state*)))
+                         ((> nsep osep) t)
+                         (t nil))
+               ;; See whether we can displace what is in this line so that we
+               ;; can use the line.
+               (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
+               (setq p (line-primary line))
+               (setq s (next-line line))
+               (push line lines)
+               (return nil)))
+           (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
       ;; Do all the displacing.
       (loop
        (when (null (cdr lines)) (return nil))
        (let ((dline (pop lines))
-	     (line (car lines)))
-	 (declare (fixnum dline line))
-	 ;;Copy from line to dline (dline is known to be free).
-	 (let ((from-loc (line-location line))
-	       (to-loc (line-location dline))
-	       (cache-vector (vector)))
-	   (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
-	   (modify-cache cache-vector
-			 (dotimes-fixnum (i (line-size))
-			   (setf (cache-vector-ref cache-vector
-						   (+ to-loc i))
-				 (cache-vector-ref cache-vector
-						   (+ from-loc i)))
-			   (setf (cache-vector-ref cache-vector
-						   (+ from-loc i))
-				 nil))))))
+             (line (car lines)))
+         (declare (fixnum dline line))
+         ;;Copy from line to dline (dline is known to be free).
+         (let ((from-loc (line-location line))
+               (to-loc (line-location dline))
+               (cache-vector (vector)))
+           (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
+           (modify-cache cache-vector
+                         (dotimes-fixnum (i (line-size))
+                           (setf (cache-vector-ref cache-vector
+                                                   (+ to-loc i))
+                                 (cache-vector-ref cache-vector
+                                                   (+ from-loc i)))
+                           (setf (cache-vector-ref cache-vector
+                                                   (+ from-loc i))
+                                 nil))))))
       (values (car lines) t))))
 
 (defun default-limit-fn (nlines)
@@ -1226,4 +1238,3 @@
     ((8 16)  4)
     (otherwise 6)))
 
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms