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

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index fc92326..7536f2a 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -204,6 +204,7 @@
 (defmacro wrapper-no-of-instance-slots (wrapper)
   `(layout-length ,wrapper))
 
+;;; FIXME: Why are these macros?
 (defmacro wrapper-instance-slots-layout (wrapper)
   `(%wrapper-instance-slots-layout ,wrapper))
 (defmacro wrapper-class-slots (wrapper)
@@ -241,35 +242,36 @@
 ;;; 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
-     :classoid
-     (let ((owrap (class-wrapper class)))
-       (cond (owrap
-	      (layout-classoid owrap))
-	     ((*subtypep (class-of class)
-			 *the-class-standard-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))))
+    ((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)
 
@@ -352,13 +354,28 @@
 (defun check-wrapper-validity (instance)
   (let* ((owrapper (wrapper-of instance))
 	 (state (layout-invalid owrapper)))
-    (if (null state)
-	owrapper
-	(ecase (car state)
-	  (:flush
-	   (flush-cache-trap owrapper (cadr state) instance))
-	  (:obsolete
-	   (obsolete-instance-trap owrapper (cadr state) instance))))))
+    (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)
@@ -634,13 +651,13 @@
 
 (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:
 ;;
@@ -924,7 +941,7 @@
   (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)))