X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=7536f2a76dadbd5b38b76fb13ff77f03fd97fcbf;hb=ae47ad0774edd8cb376772ae7e615428295f979e;hp=da804659716653b3abfca12001f3f4a361f670f7;hpb=50462f68bf70faf0bd96de7517643afb740543e6;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index da80465..7536f2a 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -96,13 +96,13 @@
   `(cache-vector-ref ,cache-vector 0))
 
 (defun flush-cache-vector-internal (cache-vector)
-  (sb-sys:without-interrupts
+  (with-pcl-lock
     (fill (the simple-vector cache-vector) nil)
     (setf (cache-vector-lock-count cache-vector) 0))
   cache-vector)
 
 (defmacro modify-cache (cache-vector &body body)
-  `(sb-sys:without-interrupts
+  `(with-pcl-lock
      (multiple-value-prog1
        (progn ,@body)
        (let ((old-count (cache-vector-lock-count ,cache-vector)))
@@ -112,7 +112,7 @@
 		   1 (the fixnum (1+ old-count))))))))
 
 (deftype field-type ()
-  '(mod #.sb-kernel:layout-clos-hash-length))
+  '(mod #.layout-clos-hash-length))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun power-of-two-ceiling (x)
@@ -143,69 +143,12 @@
 (defmacro cache-lock-count (cache)
   `(cache-vector-lock-count (cache-vector ,cache)))
 
-;;; some facilities for allocation and freeing caches as they are needed
-
-;;; This is done on the assumption that a better port of PCL will
-;;; arrange to cons these all in the same static area. Given that, the
-;;; fact that PCL tries to reuse them should be a win.
-
-(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
-
 ;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
 ;;; it. This returns a cache of exactly the size requested, it won't
 ;;; ever return a larger cache.
 (defun get-cache-vector (size)
-  (let ((entry (gethash size *free-cache-vectors*)))
-    (sb-sys:without-interrupts
-      (cond ((null entry)
-	     (setf (gethash size *free-cache-vectors*) (cons 0 nil))
-	     (get-cache-vector size))
-	    ((null (cdr entry))
-	     (incf (car entry))
-	     (flush-cache-vector-internal (allocate-cache-vector size)))
-	    (t
-	     (let ((cache (cdr entry)))
-	       (setf (cdr entry) (cache-vector-ref cache 0))
-	       (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
-  (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
-    (sb-sys:without-interrupts
-      (if (null entry)
-	  (error
-	   "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
-	  (let ((thread (cdr entry)))
-	    (loop (unless thread (return))
-		  (when (eq thread cache-vector)
-		    (error "freeing a cache twice"))
-		  (setq thread (cache-vector-ref thread 0)))
-	    (flush-cache-vector-internal cache-vector) ; to help the GC
-	    (setf (cache-vector-ref cache-vector 0) (cdr entry))
-	    (setf (cdr entry) cache-vector)
-	    nil)))))
-
-;;; This is just for debugging and analysis. It shows the state of the
-;;; free cache resource.
-#+sb-show
-(defun show-free-cache-vectors ()
-  (let ((elements ()))
-    (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
-    (setq elements (sort elements #'< :key #'car))
-    (dolist (e elements)
-      (let* ((size (car e))
-	     (entry (cadr e))
-	     (allocated (car entry))
-	     (head (cdr entry))
-	     (free 0))
-	(loop (when (null head) (return t))
-	      (setq head (cache-vector-ref head 0))
-	      (incf free))
-	(format t
-		"~&There are  ~4D caches of size  ~4D. (~D free  ~3D%)"
-		allocated
-		size
-		free
-		(floor (* 100 (/ free (float allocated)))))))))
+  (flush-cache-vector-internal (make-array size)))
+  
 
 ;;;; wrapper cache numbers
 
@@ -221,10 +164,10 @@
 ;;; are the forms of this constant which it is more convenient for the
 ;;; runtime code to use.
 (defconstant wrapper-cache-number-length
-  (integer-length sb-kernel:layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
+  (integer-length layout-clos-hash-max))
+(defconstant wrapper-cache-number-mask layout-clos-hash-max)
 (defconstant wrapper-cache-number-adds-ok
-  (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
+  (truncate most-positive-fixnum layout-clos-hash-max))
 
 ;;;; wrappers themselves
 
@@ -251,54 +194,17 @@
 ;;; have a fixed number of cache hash values, and that number must
 ;;; correspond to the number of cache lines we use.
 (defconstant wrapper-cache-number-vector-length
-  sb-kernel:layout-clos-hash-length)
+  layout-clos-hash-length)
 
 (unless (boundp '*the-class-t*)
   (setq *the-class-t* nil))
 
 (defmacro wrapper-class (wrapper)
-  `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
+  `(classoid-pcl-class (layout-classoid ,wrapper)))
 (defmacro wrapper-no-of-instance-slots (wrapper)
-  `(sb-kernel:layout-length ,wrapper))
-
-;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly)
-;;; iff the wrapper is valid. Any other return value denotes some
-;;; invalid state. Special conventions have been set up for certain
-;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN
-;;; 19991204) haven't been motivated to reverse engineer them from the
-;;; code and document them here.
-;;;
-;;; FIXME: We have removed the persistent use of this function throughout
-;;; the PCL codebase, instead opting to use INVALID-WRAPPER-P, which 
-;;; abstractly tests the return result of this function for invalidness.
-;;; However, part of the original comment that is still applicable follows.
-;;;   --njf, 2002-05-02
-;;;
-;;; FIXME: It would probably be even better to switch the sense of the
-;;; WRAPPER-STATE function, renaming it to WRAPPER-INVALID and making it
-;;; synonymous with LAYOUT-INVALID. Then the INVALID-WRAPPER-P function
-;;; would become trivial and would go away (replaced with
-;;; WRAPPER-INVALID), since all the various invalid wrapper states would
-;;; become generalized boolean "true" values. -- WHN 19991204
-#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
-(defun wrapper-state (wrapper)
-  (let ((invalid (sb-kernel:layout-invalid wrapper)))
-    (cond ((null invalid)
-	   t)
-	  ((atom invalid)
-	   ;; some non-PCL object. INVALID is probably :INVALID. We
-	   ;; should arguably compute the new wrapper here instead of
-	   ;; returning NIL, but we don't bother, since
-	   ;; OBSOLETE-INSTANCE-TRAP can't use it.
-	   '(:obsolete nil))
-	  (t
-	   invalid))))
-(defun (setf wrapper-state) (new-value wrapper)
-  (setf (sb-kernel:layout-invalid wrapper)
-	(if (eq new-value t)
-	    nil
-	    new-value)))
+  `(layout-length ,wrapper))
 
+;;; FIXME: Why are these macros?
 (defmacro wrapper-instance-slots-layout (wrapper)
   `(%wrapper-instance-slots-layout ,wrapper))
 (defmacro wrapper-class-slots (wrapper)
@@ -309,19 +215,20 @@
 ;;; whose slots are not initialized yet, and which may be built-in
 ;;; classes. We pass in the class name in addition to the class.
 (defun boot-make-wrapper (length name &optional class)
-  (let ((found (cl:find-class name nil)))
+  (let ((found (find-classoid name nil)))
     (cond
      (found
-      (unless (sb-kernel:class-pcl-class found)
-	(setf (sb-kernel:class-pcl-class found) class))
-      (aver (eq (sb-kernel:class-pcl-class found) class))
-      (let ((layout (sb-kernel:class-layout found)))
+      (unless (classoid-pcl-class found)
+	(setf (classoid-pcl-class found) class))
+      (aver (eq (classoid-pcl-class found) class))
+      (let ((layout (classoid-layout found)))
 	(aver layout)
 	layout))
      (t
       (make-wrapper-internal
        :length length
-       :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
+       :classoid (make-standard-classoid
+		  :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
@@ -332,37 +239,39 @@
 ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
 ;;; and structure classes already exist when PCL is initialized, so we
 ;;; don't necessarily always make a wrapper. Also, we help maintain
-;;; the mapping between CL:CLASS and PCL::CLASS objects.
+;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
 (defun make-wrapper (length class)
   (cond
-   ((typep class 'std-class)
-    (make-wrapper-internal
-     :length length
-     :class
-     (let ((owrap (class-wrapper class)))
-       (cond (owrap
-	      (sb-kernel:layout-class owrap))
-	     ((*subtypep (class-of class)
-			 *the-class-standard-class*)
-	      (cond ((and *pcl-class-boot*
-			  (eq (slot-value class 'name) *pcl-class-boot*))
-		     (let ((found (cl:find-class (slot-value class 'name))))
-		       (unless (sb-kernel:class-pcl-class found)
-			 (setf (sb-kernel:class-pcl-class found) class))
-		       (aver (eq (sb-kernel:class-pcl-class found) class))
-		       found))
-		    (t
-		     (sb-kernel:make-standard-class :pcl-class class))))
-	     (t
-	      (sb-kernel:make-random-pcl-class :pcl-class class))))))
-   (t
-    (let* ((found (cl:find-class (slot-value class 'name)))
-	   (layout (sb-kernel:class-layout found)))
-      (unless (sb-kernel:class-pcl-class found)
-	(setf (sb-kernel:class-pcl-class found) class))
-      (aver (eq (sb-kernel:class-pcl-class found) class))
-      (aver layout)
-      layout))))
+    ((or (typep class 'std-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))))))
+    (t
+     (let* ((found (find-classoid (slot-value class 'name)))
+	    (layout (classoid-layout found)))
+       (unless (classoid-pcl-class found)
+	 (setf (classoid-pcl-class found) class))
+       (aver (eq (classoid-pcl-class found) class))
+       (aver layout)
+       layout))))
 
 (defconstant +first-wrapper-cache-number-index+ 0)
 
@@ -388,13 +297,13 @@
 (defmacro cache-number-vector-ref (cnv n)
   `(wrapper-cache-number-vector-ref ,cnv ,n))
 (defmacro wrapper-cache-number-vector-ref (wrapper n)
-  `(sb-kernel:layout-clos-hash ,wrapper ,n))
+  `(layout-clos-hash ,wrapper ,n))
 
 (declaim (inline wrapper-class*))
 (defun wrapper-class* (wrapper)
   (or (wrapper-class wrapper)
-      (find-structure-class
-       (cl:class-name (sb-kernel:layout-class wrapper)))))
+      (ensure-non-standard-class
+       (classoid-name (layout-classoid wrapper)))))
 
 ;;; The wrapper cache machinery provides general mechanism for
 ;;; trapping on the next access to any instance of a given class. This
@@ -411,76 +320,71 @@
 
 (declaim (inline invalid-wrapper-p))
 (defun invalid-wrapper-p (wrapper)
-  (neq (wrapper-state wrapper) t))
+  (not (null (layout-invalid wrapper))))
 
 (defvar *previous-nwrappers* (make-hash-table))
 
 (defun invalidate-wrapper (owrapper state nwrapper)
-  (ecase state
-    ((:flush :obsolete)
-     (let ((new-previous ()))
-       ;; First off, a previous call to INVALIDATE-WRAPPER may have
-       ;; recorded OWRAPPER as an NWRAPPER to update to. Since
-       ;; OWRAPPER is about to be invalid, it no longer makes sense to
-       ;; update to it.
-       ;;
-       ;; We go back and change the previously invalidated wrappers so
-       ;; that they will now update directly to NWRAPPER. This
-       ;; corresponds to a kind of transitivity of wrapper updates.
-       (dolist (previous (gethash owrapper *previous-nwrappers*))
-	 (when (eq state :obsolete)
-	   (setf (car previous) :obsolete))
-	 (setf (cadr previous) nwrapper)
-	 (push previous new-previous))
-
-       (let ((ocnv (wrapper-cache-number-vector owrapper)))
-	 (dotimes (i sb-kernel:layout-clos-hash-length)
-	   (setf (cache-number-vector-ref ocnv i) 0)))
-       (push (setf (wrapper-state owrapper) (list state nwrapper))
-	     new-previous)
-
-       (setf (gethash owrapper *previous-nwrappers*) ()
-	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
+  (aver (member state '(:flush :obsolete) :test #'eq))
+  (let ((new-previous ()))
+    ;; First off, a previous call to INVALIDATE-WRAPPER may have
+    ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
+    ;; is about to be invalid, it no longer makes sense to update to
+    ;; it.
+    ;;
+    ;; We go back and change the previously invalidated wrappers so
+    ;; that they will now update directly to NWRAPPER. This
+    ;; corresponds to a kind of transitivity of wrapper updates.
+    (dolist (previous (gethash owrapper *previous-nwrappers*))
+      (when (eq state :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)))
+
+    (push (setf (layout-invalid owrapper) (list state nwrapper))
+	  new-previous)
+
+    (setf (gethash owrapper *previous-nwrappers*) ()
+	  (gethash nwrapper *previous-nwrappers*) new-previous)))
 
 (defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance)))
-    (if (not (invalid-wrapper-p owrapper))
-	owrapper
-	(let* ((state (wrapper-state wrapper))
-	       (nwrapper
-		(ecase (car state)
-		  (:flush
-		   (flush-cache-trap owrapper (cadr state) instance))
-		  (:obsolete
-		   (obsolete-instance-trap owrapper (cadr state) instance)))))
-	  ;; This little bit of error checking is superfluous. It only
-	  ;; checks to see whether the person who implemented the trap
-	  ;; handling screwed up. Since that person is hacking
-	  ;; internal PCL code, and is not a user, this should be
-	  ;; needless. Also, since this directly slows down instance
-	  ;; update and generic function cache refilling, feel free to
-	  ;; take it out sometime soon.
-	  ;;
-	  ;; FIXME: We probably need to add a #+SB-PARANOID feature to
-	  ;; make stuff like this optional. Until then, it stays in.
-	  (cond ((neq nwrapper (wrapper-of instance))
-		 (error "wrapper returned from trap not wrapper of instance"))
-		((invalid-wrapper-p nwrapper)
-		 (error "wrapper returned from trap invalid")))
-	  nwrapper))))
-
-(defmacro check-wrapper-validity1 (object)
-  (let ((owrapper (gensym)))
-    `(let ((,owrapper (sb-kernel:layout-of object)))
-       (if (sb-kernel:layout-invalid ,owrapper)
-	   (check-wrapper-validity ,object)
-	   ,owrapper))))
+  (let* ((owrapper (wrapper-of instance))
+	 (state (layout-invalid owrapper)))
+    (aver (not (eq state :uninitialized)))
+    (etypecase state
+      (null owrapper)
+      ;; FIXME: I can't help thinking that, while this does cure the
+      ;; symptoms observed from some class redefinitions, this isn't
+      ;; the place to be doing this flushing.  Nevertheless...  --
+      ;; CSR, 2003-05-31
+      ;;
+      ;; CMUCL comment:
+      ;;    We assume in this case, that the :INVALID is from a
+      ;;    previous call to REGISTER-LAYOUT for a superclass of
+      ;;    INSTANCE's class.  See also the comment above
+      ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
+      ((member t)
+       (force-cache-flushes (class-of instance))
+       (check-wrapper-validity instance))
+      (cons
+       (ecase (car state)
+	 (: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)
+  (when (invalid-wrapper-p (layout-of instance))
+    (check-wrapper-validity instance)))
 
-(defvar *free-caches* nil)
 
 (defun get-cache (nkeys valuep limit-fn nlines)
-  (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
-                   (make-cache))))
+  (let ((cache (make-cache)))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
 	(compute-cache-parameters nkeys valuep nlines)
@@ -504,8 +408,7 @@
 			     &optional (new-field +first-wrapper-cache-number-index+))
   (let ((nkeys (cache-nkeys old-cache))
 	(valuep (cache-valuep old-cache))
-	(cache (or (sb-sys:without-interrupts (pop *free-caches*))
-                   (make-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))
@@ -540,13 +443,6 @@
     (setf (cache-vector new-cache) new-vector)
     new-cache))
 
-(defun free-cache (cache)
-  (free-cache-vector (cache-vector cache))
-  (setf (cache-vector cache) #())
-  (setf (cache-owner cache) nil)
-  (push cache *free-caches*)
-  nil)
-
 (defun compute-line-size (x)
   (power-of-two-ceiling x))
 
@@ -664,6 +560,7 @@
 	(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)))
     (flet ((specializer->metatype (x)
@@ -671,22 +568,19 @@
 		     (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 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))))))
+	       (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 ~
+                            (meta-specializer ~S).~@:>"
+			   new-specializer
+			   meta-specializer))))))
       ;; We implement the following table. The notation is
       ;; that X and Y are distinct meta specializer names.
       ;;
@@ -757,20 +651,20 @@
 
 (defun dfun-arg-symbol (arg-number)
   (or (nth arg-number (the list *dfun-arg-symbols*))
-      (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
+      (format-symbol *pcl-package* ".ARG~A." arg-number)))
 
 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
 
 (defun slot-vector-symbol (arg-number)
   (or (nth arg-number (the list *slot-vector-symbols*))
-      (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
+      (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
 
 ;; FIXME: There ought to be a good way to factor out the idiom:
 ;;
 ;; (dotimes (i (length metatypes))
 ;;   (push (dfun-arg-symbol i) lambda-list))
 ;;
-;; used in the following six functions into common code that we can
+;; used in the following four functions into common code that we can
 ;; declare inline or something.  --njf 2001-12-20
 (defun make-dfun-lambda-list (metatypes applyp)
   (let ((lambda-list nil))
@@ -797,7 +691,7 @@
       (push '&rest lambda-list))
     (nreverse lambda-list)))
 
-;; FIXME: The next four functions suffer from having a `.DFUN-REST-ARG.'
+;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.'
 ;; in their lambda lists, but no corresponding `&REST' symbol.  We assume
 ;; this should be the case by analogy with the previous two functions.
 ;; It works, and I don't know why.  Check the calling functions and
@@ -813,25 +707,6 @@
 	   'invoke-effective-method-function)
       ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
 
-(defun make-dfun-call (metatypes applyp fn-variable)
-  (let ((required
-         (let ((required nil))
-           (dotimes (i (length metatypes))
-             (push (dfun-arg-symbol i) required))
-           (nreverse required))))
-    (if applyp
-	`(function-apply   ,fn-variable ,@required .dfun-rest-arg.)
-	`(function-funcall ,fn-variable ,@required))))
-
-(defun make-dfun-arg-list (metatypes applyp)
-  (let ((required (let ((reversed-required nil))
-		    (dotimes (i (length metatypes))
-		      (push (dfun-arg-symbol i) reversed-required))
-		    (nreverse reversed-required))))
-    (if applyp
-	`(list* ,@required .dfun-rest-arg.)
-	`(list ,@required))))
-
 (defun make-fast-method-call-lambda-list (metatypes applyp)
   (let ((reversed-lambda-list nil))
     (push '.pv-cell. reversed-lambda-list)
@@ -842,198 +717,207 @@
       (push '.dfun-rest-arg. reversed-lambda-list))
     (nreverse reversed-lambda-list)))
 
-;;;; a comment from some PCL implementor:
-;;;;     Its too bad Common Lisp compilers freak out when you have a
-;;;;   DEFUN with a lot of LABELS in it. If I could do that I could
-;;;;   make this code much easier to read and work with.
-;;;;     Ahh Scheme...
-;;;;     In the absence of that, the following little macro makes the
-;;;;   code that follows a little bit more reasonable. I would like to
-;;;;   add that having to practically write my own compiler in order to
-;;;;   get just this simple thing is something of a drag.
-;;;;
-;;;; KLUDGE: Maybe we could actually implement this as LABELS now,
-;;;; since AFAIK CMU CL doesn't freak out when you have a DEFUN with a
-;;;; lot of LABELS in it (and if it does we can fix it instead of
-;;;; working around it). -- WHN 19991204
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defvar *cache* nil)
-
-;;; FIXME: should be undefined after bootstrapping
-(defparameter *local-cache-functions*
-  '((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-fixnum (i (nkeys) list)
-	      (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-fixnum (i (nkeys) t)
-	      (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-fixnum (i (nkeys) wrappers-mismatch-p)
-	  (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)))))
-
 (defmacro with-local-cache-functions ((cache) &body body)
   `(let ((.cache. ,cache))
      (declare (type cache .cache.))
-     (macrolet ,(mapcar (lambda (fn)
-			  `(,(car fn) ,(cadr fn)
-			    `(let (,,@(mapcar (lambda (var)
-						``(,',var ,,var))
-					      (cadr fn)))
-			       ,@',(cddr fn))))
-			*local-cache-functions*)
+     (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))))
+       (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))
        ,@body)))
-
-) ; EVAL-WHEN
 
 ;;; Here is where we actually fill, recache and expand caches.
 ;;;
@@ -1052,19 +936,17 @@
 ;;; nice property of throwing out any entries that are invalid.
 (defvar *cache-expand-threshold* 1.25)
 
-(defun fill-cache (cache wrappers value &optional free-cache-p)
-
+(defun fill-cache (cache wrappers value)
   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
-  (unless wrappers
-    (error "fill-cache: WRAPPERS arg is NIL!"))
+  (assert wrappers)
 
   (or (fill-cache-p nil cache wrappers value)
-      (and (< (ceiling (* (cache-count cache) 1.25))
+      (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 free-cache-p))
-      (expand-cache cache wrappers value free-cache-p)))
+	   (adjust-cache cache wrappers value))
+      (expand-cache cache wrappers value)))
 
 (defvar *check-cache-p* nil)
 
@@ -1223,11 +1105,12 @@
 ;;; If this returns NIL, it means that it wasn't possible to find a
 ;;; wrapper field for which all of the entries could be put in the
 ;;; cache (within the limit).
-(defun adjust-cache (cache wrappers value free-old-cache-p)
+(defun adjust-cache (cache wrappers value)
   (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) (free-cache ncache) nil)
+      (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))
@@ -1241,12 +1124,11 @@
 		     (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
 		       (return nil)))
 		   (try-one-fill wrappers value))
-	      (progn (when free-old-cache-p (free-cache cache))
-		     (return (maybe-check-cache ncache)))
+	      (return (maybe-check-cache ncache))
 	      (flush-cache-vector-internal (cache-vector ncache))))))))
 
 ;;; returns: (values <cache>)
-(defun expand-cache (cache wrappers value free-old-cache-p)
+(defun expand-cache (cache wrappers value)
   ;;(declare (values cache))
   (with-local-cache-functions (cache)
     (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
@@ -1254,7 +1136,7 @@
 		 (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 t)
+		 (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)))
@@ -1267,7 +1149,6 @@
 	    (do-one-fill (car wrappers+value) (cdr wrappers+value))))
 	(unless (try-one-fill wrappers value)
 	  (do-one-fill wrappers value))
-	(when free-old-cache-p (free-cache cache))
 	(maybe-check-cache ncache)))))
 
 ;;; This is the heart of the cache filling mechanism. It implements
@@ -1346,24 +1227,3 @@
     (otherwise 6)))
 
 (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
-
-;;; Pre-allocate generic function caches. The hope is that this will
-;;; put them nicely together in memory, and that that may be a win. Of
-;;; course the first GC copy will probably blow that out, this really
-;;; wants to be wrapped in something that declares the area static.
-;;;
-;;; This preallocation only creates about 25% more caches than PCL
-;;; itself uses. Some ports may want to preallocate some more of
-;;; these.
-;;;
-;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do
-;;; we need it both here and there? Why? -- WHN 19991203
-(eval-when (:load-toplevel)
-  (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65)
-		    (2 64) (7 33) (16 32) (16 17) (32 16)
-		    (64 9) (64 8) (6 5) (128 4) (35 2)))
-    (let ((n (car n-size))
-	  (size (cadr n-size)))
-      (mapcar #'free-cache-vector
-	      (mapcar #'get-cache-vector
-		      (make-list n :initial-element size))))))