X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=2b84a1856bbe75bbc4ea6c197393751ad0617082;hb=b171183c7115b865b00662ff346061ecd5291ce4;hp=0879c322c7f46586d48fca0fd2730ba21ba52e06;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 0879c32..2b84a18 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -75,6 +75,8 @@ have to do any method lookup to implement itself.
 
 And so, we are saved.
 
+Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
+
 |#
 
 ;;; an alist in which each entry is of the form
@@ -103,16 +105,16 @@ And so, we are saved.
   (when (and *raise-metatypes-to-class-p*
 	     (member generator '(emit-checking emit-caching
 				 emit-in-checking-cache-p emit-constant-value)))
-    (setq args (cons (mapcar #'(lambda (mt)
-				 (if (eq mt 't)
-				     mt
-				     'class))
+    (setq args (cons (mapcar (lambda (mt)
+			       (if (eq mt t)
+				   mt
+				   'class))
 			     (car args))
 		     (cdr args))))
   (let* ((generator-entry (assq generator *dfun-constructors*))
 	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
     (if (null *enable-dfun-constructor-caching*)
-	(apply (symbol-function generator) args)
+	(apply (fdefinition generator) args)
 	(or (cadr args-entry)
 	    (multiple-value-bind (new not-best-p)
 		(apply (symbol-function generator) args)
@@ -137,10 +139,12 @@ And so, we are saved.
 		 (metatypes (car args))
 		 (gfs (when dfun-type (gfs-of-type dfun-type))))
 	    (dolist (gf gfs)
-	      (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf)))
+	      (when (and (equal metatypes
+				(arg-info-metatypes (gf-arg-info gf)))
 			 (let ((gf-name (generic-function-name gf)))
 			   (and (not (eq gf-name 'slot-value-using-class))
-				(not (equal gf-name '(setf slot-value-using-class)))
+				(not (equal gf-name
+					    '(setf slot-value-using-class)))
 				(not (eq gf-name 'slot-boundp-using-class)))))
 		(update-dfun gf)))
 	    (setf (second args-entry) constructor)
@@ -154,78 +158,133 @@ And so, we are saved.
 (defmacro precompile-dfun-constructors (&optional system)
   (let ((*precompiling-lap* t))
     `(progn
-       ,@(gathering1 (collecting)
+       ,@(let (collect)
 	   (dolist (generator-entry *dfun-constructors*)
 	     (dolist (args-entry (cdr generator-entry))
 	       (when (or (null (caddr args-entry))
 			 (eq (caddr args-entry) system))
 		 (when system (setf (caddr args-entry) system))
-		 (gather1
-		   (make-top-level-form `(precompile-dfun-constructor
-					  ,(car generator-entry))
-					'(:load-toplevel)
-		     `(load-precompiled-dfun-constructor
-		       ',(car generator-entry)
-		       ',(car args-entry)
-		       ',system
-		       ,(apply (symbol-function (car generator-entry))
-			       (car args-entry))))))))))))
+		 (push `(load-precompiled-dfun-constructor
+                         ',(car generator-entry)
+                         ',(car args-entry)
+                         ',system
+                         ,(apply (fdefinition (car generator-entry))
+                                 (car args-entry)))
+                       collect))))
+           (nreverse collect)))))
+
+;;; Standardized class slot access: when trying to break vicious
+;;; metacircles, we need a way to get at the values of slots of some
+;;; standard classes without going through the whole meta machinery,
+;;; because that would likely enter the vicious circle again.  The
+;;; following are helper functions that short-circuit the generic
+;;; lookup machinery.
+
+(defvar *standard-classes*
+  '(standard-method standard-generic-function standard-class
+    standard-effective-slot-definition))
+
+(defvar *standard-slot-locations* (make-hash-table :test 'equal))
+
+(defun compute-standard-slot-locations ()
+  (clrhash *standard-slot-locations*)
+  (dolist (class-name *standard-classes*)
+    (let ((class (find-class class-name)))
+      (dolist (slot (class-slots class))
+	(setf (gethash (cons class (slot-definition-name slot))
+		       *standard-slot-locations*)
+	      (slot-definition-location slot))))))
+
+;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS
+;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS.
+(defun maybe-update-standard-class-locations (class)
+  (when (and (eq *boot-state* 'complete)
+	     (memq (class-name class) *standard-classes*))
+    (compute-standard-slot-locations)))
+
+(defun standard-slot-value (object slot-name class)
+  (let ((location (gethash (cons class slot-name) *standard-slot-locations*)))
+    (if location
+	(let ((value (if (funcallable-instance-p object)
+			 (funcallable-standard-instance-access object location)
+			 (standard-instance-access object location))))
+	  (when (eq +slot-unbound+ value)
+	    (error "~@<slot ~S of class ~S is unbound in object ~S~@:>"
+		   slot-name class object))
+	  value)
+	(error "~@<cannot get standard value of slot ~S of class ~S ~
+                in object ~S~@:>"
+	       slot-name class object))))
+
+(defun standard-slot-value/gf (gf slot-name)
+  (standard-slot-value gf slot-name *the-class-standard-generic-function*))
+
+(defun standard-slot-value/method (method slot-name)
+  (standard-slot-value method slot-name *the-class-standard-method*))
+
+(defun standard-slot-value/eslotd (slotd slot-name)
+  (standard-slot-value slotd slot-name
+		       *the-class-standard-effective-slot-definition*))
+
+(defun standard-slot-value/class (class slot-name)
+  (standard-slot-value class slot-name *the-class-standard-class*))
 
-;;; When all the methods of a generic function are automatically generated
-;;; reader or writer methods a number of special optimizations are possible.
-;;; These are important because of the large number of generic functions of
-;;; this type.
+;;; When all the methods of a generic function are automatically
+;;; generated reader or writer methods a number of special
+;;; optimizations are possible. These are important because of the
+;;; large number of generic functions of this type.
 ;;;
 ;;; There are a number of cases:
 ;;;
 ;;;   ONE-CLASS-ACCESSOR
-;;;     In this case, the accessor generic function has only been called
-;;;     with one class of argument. There is no cache vector, the wrapper
-;;;     of the one class, and the slot index are stored directly as closure
-;;;     variables of the discriminating function. This case can convert to
-;;;     either of the next kind.
+;;;     In this case, the accessor generic function has only been
+;;;     called with one class of argument. There is no cache vector,
+;;;     the wrapper of the one class, and the slot index are stored
+;;;     directly as closure variables of the discriminating function.
+;;;     This case can convert to either of the next kind.
 ;;;
 ;;;   TWO-CLASS-ACCESSOR
-;;;     Like above, but two classes. This is common enough to do specially.
-;;;     There is no cache vector. The two classes are stored a separate
-;;;     closure variables.
+;;;     Like above, but two classes. This is common enough to do
+;;;     specially. There is no cache vector. The two classes are
+;;;     stored a separate closure variables.
 ;;;
 ;;;   ONE-INDEX-ACCESSOR
-;;;     In this case, the accessor generic function has seen more than one
-;;;     class of argument, but the index of the slot is the same for all
-;;;     the classes that have been seen. A cache vector is used to store
-;;;     the wrappers that have been seen, the slot index is stored directly
-;;;     as a closure variable of the discriminating function. This case
-;;;     can convert to the next kind.
+;;;     In this case, the accessor generic function has seen more than
+;;;     one class of argument, but the index of the slot is the same
+;;;     for all the classes that have been seen. A cache vector is
+;;;     used to store the wrappers that have been seen, the slot index
+;;;     is stored directly as a closure variable of the discriminating
+;;;     function. This case can convert to the next kind.
 ;;;
 ;;;   N-N-ACCESSOR
-;;;     This is the most general case. In this case, the accessor generic
-;;;     function has seen more than one class of argument and more than one
-;;;     slot index. A cache vector stores the wrappers and corresponding
-;;;     slot indexes. Because each cache line is more than one element
-;;;     long, a cache lock count is used.
-(defstruct (dfun-info (:constructor nil))
+;;;     This is the most general case. In this case, the accessor
+;;;     generic function has seen more than one class of argument and
+;;;     more than one slot index. A cache vector stores the wrappers
+;;;     and corresponding slot indexes. Because each cache line is
+;;;     more than one element long, a cache lock count is used.
+(defstruct (dfun-info (:constructor nil)
+		      (:copier nil))
   (cache nil))
 
-(defstruct (no-methods
-	     (:constructor no-methods-dfun-info ())
-	     (:include dfun-info)))
+(defstruct (no-methods (:constructor no-methods-dfun-info ())
+		       (:include dfun-info)
+		       (:copier nil)))
 
-(defstruct (initial
-	     (:constructor initial-dfun-info ())
-	     (:include dfun-info)))
+(defstruct (initial (:constructor initial-dfun-info ())
+		    (:include dfun-info)
+		    (:copier nil)))
 
-(defstruct (initial-dispatch
-	     (:constructor initial-dispatch-dfun-info ())
-	     (:include dfun-info)))
+(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ())
+			     (:include dfun-info)
+			     (:copier nil)))
 
-(defstruct (dispatch
-	     (:constructor dispatch-dfun-info ())
-	     (:include dfun-info)))
+(defstruct (dispatch (:constructor dispatch-dfun-info ())
+		     (:include dfun-info)
+		     (:copier nil)))
 
-(defstruct (default-method-only
-	     (:constructor default-method-only-dfun-info ())
-	     (:include dfun-info)))
+(defstruct (default-method-only (:constructor default-method-only-dfun-info ())
+	                        (:include dfun-info)
+				(:copier nil)))
 
 ;without caching:
 ;  dispatch one-class two-class default-method-only
@@ -235,62 +294,64 @@ And so, we are saved.
 
 ;accessor:
 ;  one-class two-class one-index n-n
-(defstruct (accessor-dfun-info
-	     (:constructor nil)
-	     (:include dfun-info))
+(defstruct (accessor-dfun-info (:constructor nil)
+			       (:include dfun-info)
+			       (:copier nil))
   accessor-type) ; (member reader writer)
 
 (defmacro dfun-info-accessor-type (di)
   `(accessor-dfun-info-accessor-type ,di))
 
-(defstruct (one-index-dfun-info
-	     (:constructor nil)
-	     (:include accessor-dfun-info))
+(defstruct (one-index-dfun-info (:constructor nil)
+				(:include accessor-dfun-info)
+				(:copier nil))
   index)
 
 (defmacro dfun-info-index (di)
   `(one-index-dfun-info-index ,di))
 
-(defstruct (n-n
-	     (:constructor n-n-dfun-info (accessor-type cache))
-	     (:include accessor-dfun-info)))
+(defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache))
+		(:include accessor-dfun-info)
+		(:copier nil)))
 
-(defstruct (one-class
-	     (:constructor one-class-dfun-info (accessor-type index wrapper0))
-	     (:include one-index-dfun-info))
+(defstruct (one-class (:constructor one-class-dfun-info
+				    (accessor-type index wrapper0))
+		      (:include one-index-dfun-info)
+		      (:copier nil))
   wrapper0)
 
 (defmacro dfun-info-wrapper0 (di)
   `(one-class-wrapper0 ,di))
 
-(defstruct (two-class
-	     (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
-	     (:include one-class))
+(defstruct (two-class (:constructor two-class-dfun-info
+				    (accessor-type index wrapper0 wrapper1))
+		      (:include one-class)
+		      (:copier nil))
   wrapper1)
 
 (defmacro dfun-info-wrapper1 (di)
   `(two-class-wrapper1 ,di))
 
-(defstruct (one-index
-	     (:constructor one-index-dfun-info
-			   (accessor-type index cache))
-	     (:include one-index-dfun-info)))
+(defstruct (one-index (:constructor one-index-dfun-info
+				    (accessor-type index cache))
+		      (:include one-index-dfun-info)
+		      (:copier nil)))
 
-(defstruct (checking
-	     (:constructor checking-dfun-info (function cache))
-	     (:include dfun-info))
+(defstruct (checking (:constructor checking-dfun-info (function cache))
+		     (:include dfun-info)
+		     (:copier nil))
   function)
 
 (defmacro dfun-info-function (di)
   `(checking-function ,di))
 
-(defstruct (caching
-	     (:constructor caching-dfun-info (cache))
-	     (:include dfun-info)))
+(defstruct (caching (:constructor caching-dfun-info (cache))
+		    (:include dfun-info)
+		    (:copier nil)))
 
-(defstruct (constant-value
-	     (:constructor constant-value-dfun-info (cache))
-	     (:include dfun-info)))
+(defstruct (constant-value (:constructor constant-value-dfun-info (cache))
+			   (:include dfun-info)
+			   (:copier nil)))
 
 (defmacro dfun-update (generic-function function &rest args)
   `(multiple-value-bind (dfun cache info)
@@ -299,7 +360,7 @@ And so, we are saved.
 
 (defun accessor-miss-function (gf dfun-info)
   (ecase (dfun-info-accessor-type dfun-info)
-    (reader
+    ((reader boundp)
      (lambda (arg)
        (accessor-miss gf nil arg dfun-info)))
     (writer
@@ -309,7 +370,10 @@ And so, we are saved.
 #-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
 
 (defun make-one-class-accessor-dfun (gf type wrapper index)
-  (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
+  (let ((emit (ecase type
+		(reader 'emit-one-class-reader)
+		(boundp 'emit-one-class-boundp)
+		(writer 'emit-one-class-writer)))
 	(dfun-info (one-class-dfun-info type index wrapper)))
     (values
      (funcall (get-dfun-constructor emit (consp index))
@@ -319,7 +383,10 @@ And so, we are saved.
      dfun-info)))
 
 (defun make-two-class-accessor-dfun (gf type w0 w1 index)
-  (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
+  (let ((emit (ecase type
+		(reader 'emit-two-class-reader)
+		(boundp 'emit-two-class-boundp)
+		(writer 'emit-two-class-writer)))
 	(dfun-info (two-class-dfun-info type index w0 w1)))
     (values
      (funcall (get-dfun-constructor emit (consp index))
@@ -330,7 +397,10 @@ And so, we are saved.
 
 ;;; std accessors same index dfun
 (defun make-one-index-accessor-dfun (gf type index &optional cache)
-  (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
+  (let* ((emit (ecase type
+		 (reader 'emit-one-index-readers)
+		 (boundp 'emit-one-index-boundps)
+		 (writer 'emit-one-index-writers)))
 	 (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
 	 (dfun-info (one-index-dfun-info type index cache)))
     (declare (type cache cache))
@@ -350,7 +420,10 @@ And so, we are saved.
   (default-limit-fn nlines))
 
 (defun make-n-n-accessor-dfun (gf type &optional cache)
-  (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
+  (let* ((emit (ecase type
+		 (reader 'emit-n-n-readers)
+		 (boundp 'emit-n-n-boundps)
+		 (writer 'emit-n-n-writers)))
 	 (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
 	 (dfun-info (n-n-dfun-info type cache)))
     (declare (type cache cache))
@@ -375,9 +448,9 @@ And so, we are saved.
     (when (use-dispatch-dfun-p generic-function)
       (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+    (if (every (lambda (mt) (eq mt t)) metatypes)
 	(let ((dfun-info (default-method-only-dfun-info)))
 	  (values
 	   (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
@@ -398,9 +471,9 @@ And so, we are saved.
 (defun make-final-checking-dfun (generic-function function
 						  classes-list new-class)
   (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
-	(values #'(lambda (&rest args)
-		    (invoke-emf function args))
+    (if (every (lambda (mt) (eq mt t)) metatypes)
+	(values (lambda (&rest args)
+		  (invoke-emf function args))
 		nil (default-method-only-dfun-info))
 	(let ((cache (make-final-ordinary-dfun-internal
 		      generic-function nil #'checking-limit-fn
@@ -409,16 +482,16 @@ And so, we are saved.
 
 (defun use-default-method-only-dfun-p (generic-function)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq applyp nkeys))
-    (every #'(lambda (mt) (eq mt 't)) metatypes)))
+    (every (lambda (mt) (eq mt t)) metatypes)))
 
 (defun use-caching-dfun-p (generic-function)
   (some (lambda (method)
 	  (let ((fmf (if (listp method)
 			 (third method)
 			 (method-fast-function method))))
-	    (method-function-get fmf ':slot-name-lists)))
+	    (method-function-get fmf :slot-name-lists)))
 	;; KLUDGE: As of sbcl-0.6.4, it's very important for
 	;; efficiency to know the type of the sequence argument to
 	;; quantifiers (SOME/NOTANY/etc.) at compile time, but
@@ -436,11 +509,13 @@ And so, we are saved.
 (defun make-caching-dfun (generic-function &optional cache)
   (unless cache
     (when (use-constant-value-dfun-p generic-function)
-      (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
+      (return-from make-caching-dfun
+	(make-constant-value-dfun generic-function)))
     (when (use-dispatch-dfun-p generic-function)
-      (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
+      (return-from make-caching-dfun
+	(make-dispatch-dfun generic-function))))
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq))
     (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
 	   (dfun-info (caching-dfun-info cache)))
@@ -463,17 +538,17 @@ And so, we are saved.
 
 (defun insure-caching-dfun (gf)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
+      (get-generic-fun-info gf)
     (declare (ignore nreq nkeys))
     (when (and metatypes
 	       (not (null (car metatypes)))
 	       (dolist (mt metatypes nil)
-		 (unless (eq mt 't) (return t))))
+		 (unless (eq mt t) (return t))))
       (get-dfun-constructor 'emit-caching metatypes applyp))))
 
 (defun use-constant-value-dfun-p (gf &optional boolean-values-p)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info gf)
+      (get-generic-fun-info gf)
     (declare (ignore nreq metatypes nkeys))
     (let* ((early-p (early-gf-p gf))
 	   (methods (if early-p
@@ -482,25 +557,45 @@ And so, we are saved.
 	   (default '(unknown)))
       (and (null applyp)
 	   (or (not (eq *boot-state* 'complete))
-	       (compute-applicable-methods-emf-std-p gf))
-	   (notany #'(lambda (method)
-		       (or (and (eq *boot-state* 'complete)
-				(some #'eql-specializer-p
-				      (method-specializers method)))
-			   (let ((value (method-function-get
-					 (if early-p
-					     (or (third method) (second method))
-					     (or (method-fast-function method)
-						 (method-function method)))
-					 :constant-value default)))
-			     (if boolean-values-p
-				 (not (or (eq value 't) (eq value nil)))
-				 (eq value default)))))
-		   methods)))))
+	       ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
+	       ;; can't use this, of course, because we can't tell
+	       ;; which methods will be considered applicable.
+	       ;;
+	       ;; Also, don't use this dfun method if the generic
+	       ;; function has a non-standard method combination,
+	       ;; because if it has, it's not sure that method
+	       ;; functions are used directly as effective methods,
+	       ;; which CONSTANT-VALUE-MISS depends on.  The
+	       ;; pre-defined method combinations like LIST are
+	       ;; examples of that.
+	       (and (compute-applicable-methods-emf-std-p gf)
+		    (eq (generic-function-method-combination gf)
+			*standard-method-combination*)))
+	   ;; Check that no method is eql-specialized, and that all
+	   ;; methods return a constant value.  If BOOLEAN-VALUES-P,
+	   ;; check that all return T or NIL.  Also, check that no
+	   ;; method has qualifiers, to make sure that emfs are really
+	   ;; method functions; see above.
+	   (dolist (method methods t)
+	     (when (eq *boot-state* 'complete)
+	       (when (or (some #'eql-specializer-p
+			       (method-specializers method))
+			 (method-qualifiers method))
+		 (return nil)))
+	     (let ((value (method-function-get
+			   (if early-p
+			       (or (third method) (second method))
+			       (or (method-fast-function method)
+				   (method-function method)))
+			   :constant-value default)))
+	       (when (or (eq value default)
+			 (and boolean-values-p
+			      (not (member value '(t nil)))))
+		 (return nil))))))))
 
 (defun make-constant-value-dfun (generic-function &optional cache)
   (multiple-value-bind (nreq applyp metatypes nkeys)
-      (get-generic-function-info generic-function)
+      (get-generic-fun-info generic-function)
     (declare (ignore nreq applyp))
     (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
 	   (dfun-info (constant-value-dfun-info cache)))
@@ -520,7 +615,7 @@ And so, we are saved.
 
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
   (when (eq *boot-state* 'complete)
-    (unless caching-p
+    (unless (or caching-p (gf-requires-emf-keyword-checks gf))
       ;; This should return T when almost all dispatching is by
       ;; eql specializers or built-in classes. In other words,
       ;; return NIL if we might ever need to do more than
@@ -539,57 +634,33 @@ And so, we are saved.
 (defparameter *structure-typep-cost* 1)
 (defparameter *built-in-typep-cost* 0)
 
-;;; The execution time of this version is exponential to some function
-;;; of number of gf methods and argument lists. It was taking
-;;; literally hours to load the presentation methods from the
-;;; cl-http w3p kit.
-#+nil
-(defun dispatch-dfun-cost (gf)
-  (generate-discrimination-net-internal
-   gf (generic-function-methods gf) nil
-   #'(lambda (methods known-types)
-       (declare (ignore methods known-types))
-       0)
-   #'(lambda (position type true-value false-value)
-       (declare (ignore position))
-       (+ (max true-value false-value)
-	  (if (eq 'class (car type))
-	      (let ((cpl (class-precedence-list (class-of (cadr type)))))
-		(cond((memq *the-class-built-in-class* cpl)
-		      *built-in-typep-cost*)
-		     ((memq *the-class-structure-class* cpl)
-		      *structure-typep-cost*)
-		     (t
-		      *non-built-in-typep-cost*)))
-	      0)))
-   #'identity))
-
-;;; This version is from the pcl found in the gcl-2.1 distribution.
-;;; Someone added a cost limit so as to keep the execution time controlled
+;;; According to comments in the original CMU CL version of PCL,
+;;; the cost LIMIT is important to cut off exponential growth for
+;;; large numbers of gf methods and argument lists.
 (defun dispatch-dfun-cost (gf &optional limit)
   (generate-discrimination-net-internal
    gf (generic-function-methods gf) nil
-   #'(lambda (methods known-types)
-       (declare (ignore methods known-types))
-       0)
-   #'(lambda (position type true-value false-value)
-       (declare (ignore position))
-       (let* ((type-test-cost
-	       (if (eq 'class (car type))
-		   (let* ((metaclass (class-of (cadr type)))
-			  (mcpl (class-precedence-list metaclass)))
-		     (cond ((memq *the-class-built-in-class* mcpl)
-			    *built-in-typep-cost*)
-			   ((memq *the-class-structure-class* mcpl)
-			    *structure-typep-cost*)
-			   (t
-			    *non-built-in-typep-cost*)))
-		   0))
-	      (max-cost-so-far
-	       (+ (max true-value false-value) type-test-cost)))
-	 (when (and limit (<= limit max-cost-so-far))
-	   (return-from dispatch-dfun-cost max-cost-so-far))
-	   max-cost-so-far))
+   (lambda (methods known-types)
+     (declare (ignore methods known-types))
+     0)
+   (lambda (position type true-value false-value)
+     (declare (ignore position))
+     (let* ((type-test-cost
+	     (if (eq 'class (car type))
+		 (let* ((metaclass (class-of (cadr type)))
+			(mcpl (class-precedence-list metaclass)))
+		   (cond ((memq *the-class-built-in-class* mcpl)
+			  *built-in-typep-cost*)
+			 ((memq *the-class-structure-class* mcpl)
+			  *structure-typep-cost*)
+			 (t
+			  *non-built-in-typep-cost*)))
+		 0))
+	    (max-cost-so-far
+	     (+ (max true-value false-value) type-test-cost)))
+       (when (and limit (<= limit max-cost-so-far))
+	 (return-from dispatch-dfun-cost max-cost-so-far))
+       max-cost-so-far))
    #'identity))
 
 (defparameter *cache-lookup-cost* 1)
@@ -613,14 +684,20 @@ And so, we are saved.
 (setq *wrapper-of-cost* 15)
 (setq *secondary-dfun-call-cost* 30)
 
+(declaim (inline make-callable))
+(defun make-callable (gf methods generator method-alist wrappers)
+  (let* ((*applicable-methods* methods)
+	 (callable (function-funcall generator method-alist wrappers)))
+    callable))
+
 (defun make-dispatch-dfun (gf)
   (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
 
 (defun get-dispatch-function (gf)
-  (let ((methods (generic-function-methods gf)))
-    (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil
-							nil nil t)
-		      nil nil)))
+  (let* ((methods (generic-function-methods gf))
+	 (generator (get-secondary-dispatch-function1
+		     gf methods nil nil nil nil nil t)))
+    (make-callable gf methods generator nil nil)))
 
 (defun make-final-dispatch-dfun (gf)
   (make-dispatch-dfun gf))
@@ -632,11 +709,10 @@ And so, we are saved.
 (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
   (let ((cache (or cache (get-cache nkeys valuep limit-fn
 				    (+ (hash-table-count table) 3)))))
-    (maphash #'(lambda (classes value)
-		 (setq cache (fill-cache cache
-					 (class-wrapper classes)
-					 value
-					 t)))
+    (maphash (lambda (classes value)
+	       (setq cache (fill-cache cache
+				       (class-wrapper classes)
+				       value)))
 	     table)
     cache))
 
@@ -666,68 +742,108 @@ And so, we are saved.
        (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
 					    (type 'accessor)
 					    (t 'checking)))
-     (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
-       (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
-	 ,@body))
-     (invoke-emf ,nemf ,args)))
+    (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+      (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
+	,@body))
+    ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
+    ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
+    ;; does not signal a SLOT-UNBOUND error for a boundp test.
+    ,@(if type
+	  ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
+	  ;; slots?)
+	  `((if (and (eq ,type 'boundp) (integerp ,nemf))
+		(invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
+		(invoke-emf ,nemf ,args)))
+	  `((invoke-emf ,nemf ,args)))))
 
 ;;; The dynamically adaptive method lookup algorithm is implemented is
-;;; implemented as a kind of state machine. The kinds of discriminating
-;;; function is the state, the various kinds of reasons for a cache miss
-;;; are the state transitions.
+;;; implemented as a kind of state machine. The kinds of
+;;; discriminating function is the state, the various kinds of reasons
+;;; for a cache miss are the state transitions.
 ;;;
-;;; The code which implements the transitions is all in the miss handlers
-;;; for each kind of dfun. Those appear here.
+;;; The code which implements the transitions is all in the miss
+;;; handlers for each kind of dfun. Those appear here.
 ;;;
-;;; Note that within the states that cache, there are dfun updates which
-;;; simply select a new cache or cache field. Those are not considered
-;;; as state transitions.
+;;; Note that within the states that cache, there are dfun updates
+;;; which simply select a new cache or cache field. Those are not
+;;; considered as state transitions.
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
 
+(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*))
+(defvar *max-emf-precomputation-methods* nil)
+
+(defun finalize-specializers (gf)
+  (let ((methods (generic-function-methods gf)))
+    (when (or (null *max-emf-precomputation-methods*)
+	      (<= (length methods) *max-emf-precomputation-methods*))
+      (let ((all-finalized t))
+	(dolist (method methods all-finalized)
+	  (dolist (specializer (method-specializers method))
+	    (when (and (classp specializer)
+		       (not (class-finalized-p specializer)))
+	      (if (class-has-a-forward-referenced-superclass-p specializer)
+		  (setq all-finalized nil)
+		  (finalize-inheritance specializer)))))))))
+
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
-	 #'(sb-kernel:instance-lambda (&rest args)
+	 #'(instance-lambda (&rest args)
 	     (initial-dfun gf args))))
     (multiple-value-bind (dfun cache info)
-	(if (and (eq *boot-state* 'complete)
-		 (compute-applicable-methods-emf-std-p gf))
-	    (let* ((caching-p (use-caching-dfun-p gf))
-		   (classes-list (precompute-effective-methods
-				  gf caching-p
-				  (not *lazy-dfun-compute-p*))))
-	      (if *lazy-dfun-compute-p*
-		  (cond ((use-dispatch-dfun-p gf caching-p)
-			 (values initial-dfun
-				 nil
-				 (initial-dispatch-dfun-info)))
-			(caching-p
-			 (insure-caching-dfun gf)
-			 (values initial-dfun nil (initial-dfun-info)))
-			(t
-			 (values initial-dfun nil (initial-dfun-info))))
-		  (make-final-dfun-internal gf classes-list)))
-	    (let ((arg-info (if (early-gf-p gf)
-				(early-gf-arg-info gf)
-				(gf-arg-info gf)))
-		  (type nil))
-	      (if (and (gf-precompute-dfun-and-emf-p arg-info)
-		       (setq type (final-accessor-dfun-type gf)))
-		  (if *early-p*
-		      (values (make-early-accessor gf type) nil nil)
-		      (make-final-accessor-dfun gf type))
-		  (values initial-dfun nil (initial-dfun-info)))))
+	(cond
+	  ((and (eq *boot-state* 'complete)
+		(not (finalize-specializers gf)))
+	   (values initial-dfun nil (initial-dfun-info)))
+	  ((and (eq *boot-state* 'complete)
+		(compute-applicable-methods-emf-std-p gf))
+	   (let* ((caching-p (use-caching-dfun-p gf))
+		  ;; KLUDGE: the only effect of this (when
+		  ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is)
+		  ;; is to signal an error when we try to add methods
+		  ;; with the wrong qualifiers to a generic function.
+		  (classes-list (precompute-effective-methods
+				 gf caching-p
+				 (not *lazy-dfun-compute-p*))))
+	     (if *lazy-dfun-compute-p*
+		 (cond ((use-dispatch-dfun-p gf caching-p)
+			(values initial-dfun
+				nil
+				(initial-dispatch-dfun-info)))
+		       (caching-p
+			(insure-caching-dfun gf)
+			(values initial-dfun nil (initial-dfun-info)))
+		       (t
+			(values initial-dfun nil (initial-dfun-info))))
+		 (make-final-dfun-internal gf classes-list))))
+	  (t
+	   (let ((arg-info (if (early-gf-p gf)
+			       (early-gf-arg-info gf)
+			       (gf-arg-info gf)))
+		 (type nil))
+	     (if (and (gf-precompute-dfun-and-emf-p arg-info)
+		      (setq type (final-accessor-dfun-type gf)))
+		 (if *early-p*
+		     (values (make-early-accessor gf type) nil nil)
+		     (make-final-accessor-dfun gf type))
+		 (values initial-dfun nil (initial-dfun-info))))))
       (set-dfun gf dfun cache info))))
 
 (defun make-early-accessor (gf type)
   (let* ((methods (early-gf-methods gf))
 	 (slot-name (early-method-standard-accessor-slot-name (car methods))))
     (ecase type
-      (reader #'(sb-kernel:instance-lambda (instance)
+      (reader #'(instance-lambda (instance)
 		  (let* ((class (class-of instance))
 			 (class-name (!bootstrap-get-slot 'class class 'name)))
 		    (!bootstrap-get-slot class-name instance slot-name))))
-      (writer #'(sb-kernel:instance-lambda (new-value instance)
+      (boundp #'(instance-lambda (instance)
+		  (let* ((class (class-of instance))
+			 (class-name (!bootstrap-get-slot 'class class 'name)))
+		    (not (eq +slot-unbound+
+			     (!bootstrap-get-slot class-name
+						  instance slot-name))))))
+      (writer #'(instance-lambda (new-value instance)
 		  (let* ((class (class-of instance))
 			 (class-name (!bootstrap-get-slot 'class class 'name)))
 		    (!bootstrap-set-slot class-name instance slot-name new-value)))))))
@@ -772,18 +888,25 @@ And so, we are saved.
   (let ((methods (if (early-gf-p gf)
 		     (early-gf-methods gf)
 		     (generic-function-methods gf))))
-    (cond ((every #'(lambda (method)
-		      (if (consp method)
-			  (eq *the-class-standard-reader-method*
-			      (early-method-class method))
-			  (standard-reader-method-p method)))
+    (cond ((every (lambda (method)
+		    (if (consp method)
+			(eq *the-class-standard-reader-method*
+			    (early-method-class method))
+			(standard-reader-method-p method)))
 		  methods)
 	   'reader)
-	  ((every #'(lambda (method)
-		      (if (consp method)
-			  (eq *the-class-standard-writer-method*
-			      (early-method-class method))
-			  (standard-writer-method-p method)))
+	  ((every (lambda (method)
+		    (if (consp method)
+			(eq *the-class-standard-boundp-method*
+			    (early-method-class method))
+			(standard-boundp-method-p method)))
+		  methods)
+	   'boundp)
+	  ((every (lambda (method)
+		    (if (consp method)
+			(eq *the-class-standard-writer-method*
+			    (early-method-class method))
+			(standard-writer-method-p method)))
 		  methods)
 	   'writer))))
 
@@ -814,20 +937,20 @@ And so, we are saved.
 	specls all-same-p)
     (cond ((null methods)
 	   (values
-	    #'(sb-kernel:instance-lambda (&rest args)
+	    #'(instance-lambda (&rest args)
 		(apply #'no-applicable-method gf args))
 	    nil
 	    (no-methods-dfun-info)))
 	  ((setq type (final-accessor-dfun-type gf))
 	   (make-final-accessor-dfun gf type classes-list new-class))
-	  ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*))
+	  ((and (not (and (every (lambda (specl) (eq specl *the-class-t*))
 				 (setq specls
 				       (method-specializers (car methods))))
 			  (setq all-same-p
-				(every #'(lambda (method)
-					   (and (equal specls
-						       (method-specializers
-							method))))
+				(every (lambda (method)
+					 (and (equal specls
+						     (method-specializers
+						      method))))
 				       methods))))
 		(use-constant-value-dfun-p gf))
 	   (make-final-constant-value-dfun gf classes-list new-class))
@@ -843,9 +966,11 @@ And so, we are saved.
   (let* ((ostate (type-of dfun-info))
 	 (otype (dfun-info-accessor-type dfun-info))
 	 oindex ow0 ow1 cache
-	 (args (ecase otype			; The congruence rules ensure
-		(reader (list object))		; that this is safe despite not
-		(writer (list new object)))))	; knowing the new type yet.
+	 (args (ecase otype
+		 ;; The congruence rules ensure that this is safe
+		 ;; despite not knowing the new type yet.
+		 ((reader boundp) (list object))
+		 (writer (list new object)))))	
     (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
 
       ;; The following lexical functions change the state of the
@@ -907,8 +1032,8 @@ And so, we are saved.
 		  (setq oindex (dfun-info-index dfun-info))
 		  (setq cache (dfun-info-cache dfun-info))
 		  (if (eql nindex oindex)
-		      (do-fill #'(lambda (ncache)
-				   (one-index nindex ncache)))
+		      (do-fill (lambda (ncache)
+				 (one-index nindex ncache)))
 		      (n-n)))
 		 (n-n
 		  (setq cache (dfun-info-cache dfun-info))
@@ -942,20 +1067,22 @@ And so, we are saved.
 (defun constant-value-miss (generic-function args dfun-info)
   (let ((ocache (dfun-info-cache dfun-info)))
     (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
-      (cond (invalidp)
-	    (t
-	     (let* ((function (typecase emf
-				(fast-method-call (fast-method-call-function
-						   emf))
-				(method-call (method-call-function emf))))
-		    (value (method-function-get function :constant-value))
-		    (ncache (fill-cache ocache wrappers value)))
-	       (unless (eq ncache ocache)
-		 (dfun-update generic-function
-			      #'make-constant-value-dfun ncache))))))))
+      (unless invalidp
+	(let* ((function
+		(typecase emf
+		  (fast-method-call (fast-method-call-function emf))
+		  (method-call (method-call-function emf))))
+	       (value (let ((val (method-function-get
+				  function :constant-value '.not-found.)))
+			(aver (not (eq val '.not-found.)))
+			val))
+	       (ncache (fill-cache ocache wrappers value)))
+	  (unless (eq ncache ocache)
+	    (dfun-update generic-function
+			 #'make-constant-value-dfun ncache)))))))
 
-;;; Given a generic function and a set of arguments to that generic function,
-;;; returns a mess of values.
+;;; Given a generic function and a set of arguments to that generic
+;;; function, return a mess of values.
 ;;;
 ;;;  <function>   The compiled effective method function for this set of
 ;;;	       arguments.
@@ -984,58 +1111,140 @@ And so, we are saved.
 ;;;  <index>      If <type> is READER or WRITER, and the slot accessed is
 ;;;	       an :instance slot, this is the index number of that slot
 ;;;	       in the object argument.
+(defvar *cache-miss-values-stack* ())
+
 (defun cache-miss-values (gf args state)
-  (if (null (if (early-gf-p gf)
-		(early-gf-methods gf)
-		(generic-function-methods gf)))
-      (apply #'no-applicable-method gf args)
-      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
-	  (get-generic-function-info gf)
-	(declare (ignore nreq applyp nkeys))
-	(with-dfun-wrappers (args metatypes)
-	  (dfun-wrappers invalid-wrapper-p wrappers classes types)
-	  (error "The function ~S requires at least ~D arguments"
-		 gf (length metatypes))
-	  (multiple-value-bind (emf methods accessor-type index)
-	      (cache-miss-values-internal gf arg-info wrappers classes types state)
-	    (values emf methods
-		    dfun-wrappers
-		    invalid-wrapper-p
-		    accessor-type index))))))
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-fun-info gf)
+    (declare (ignore nreq applyp nkeys))
+    (with-dfun-wrappers (args metatypes)
+      (dfun-wrappers invalid-wrapper-p wrappers classes types)
+      (error-need-at-least-n-args gf (length metatypes))
+      (multiple-value-bind (emf methods accessor-type index)
+          (cache-miss-values-internal
+           gf arg-info wrappers classes types state)
+        (values emf methods
+                dfun-wrappers
+                invalid-wrapper-p
+                accessor-type index)))))
 
 (defun cache-miss-values-internal (gf arg-info wrappers classes types state)
+  (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*))))
+      (break-vicious-metacircle gf classes arg-info)
+      (let ((*cache-miss-values-stack*
+	     (acons gf classes *cache-miss-values-stack*))
+	    (cam-std-p (or (null arg-info)
+			   (gf-info-c-a-m-emf-std-p arg-info))))
+	(multiple-value-bind (methods all-applicable-and-sorted-p)
+	    (if cam-std-p
+		(compute-applicable-methods-using-types gf types)
+		(compute-applicable-methods-using-classes gf classes))
+	  
   (let* ((for-accessor-p (eq state 'accessor))
 	 (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
-	 (cam-std-p (or (null arg-info)
-			(gf-info-c-a-m-emf-std-p arg-info))))
-    (multiple-value-bind (methods all-applicable-and-sorted-p)
-	(if cam-std-p
-	    (compute-applicable-methods-using-types gf types)
-	    (compute-applicable-methods-using-classes gf classes))
-      (let ((emf (if (or cam-std-p all-applicable-and-sorted-p)
-		     (function-funcall (get-secondary-dispatch-function1
-					gf methods types nil (and for-cache-p wrappers)
-					all-applicable-and-sorted-p)
-				       nil (and for-cache-p wrappers))
-		     (default-secondary-dispatch-function gf))))
-	(multiple-value-bind (index accessor-type)
-	    (and for-accessor-p all-applicable-and-sorted-p methods
-		 (accessor-values gf arg-info classes methods))
-	  (values (if (integerp index) index emf)
-		  methods accessor-type index))))))
+	 (emf (if (or cam-std-p all-applicable-and-sorted-p)
+		  (let ((generator
+			 (get-secondary-dispatch-function1
+			  gf methods types nil (and for-cache-p wrappers)
+			  all-applicable-and-sorted-p)))
+		    (make-callable gf methods generator
+				   nil (and for-cache-p wrappers)))
+		  (default-secondary-dispatch-function gf))))
+    (multiple-value-bind (index accessor-type)
+	(and for-accessor-p all-applicable-and-sorted-p methods
+	     (accessor-values gf arg-info classes methods))
+      (values (if (integerp index) index emf)
+	      methods accessor-type index)))))))
+
+;;; Try to break a vicious circle while computing a cache miss.
+;;; GF is the generic function, CLASSES are the classes of actual
+;;; arguments, and ARG-INFO is the generic functions' arg-info.
+;;;
+;;; A vicious circle can be entered when the computation of the cache
+;;; miss values itself depends on the values being computed.  For
+;;; instance, adding a method which is an instance of a subclass of
+;;; STANDARD-METHOD leads to cache misses for slot accessors of
+;;; STANDARD-METHOD like METHOD-SPECIALIZERS, and METHOD-SPECIALIZERS
+;;; is itself used while we compute cache miss values.
+(defun break-vicious-metacircle (gf classes arg-info)
+  (when (typep gf 'standard-generic-function)
+    (multiple-value-bind (class slotd accessor-type)
+	(accesses-standard-class-slot-p gf)
+      (when class
+	(let ((method (find-standard-class-accessor-method
+		       gf class accessor-type))
+	      (index (standard-slot-value/eslotd slotd 'location))
+	      (type (gf-info-simple-accessor-type arg-info)))
+	  (when (and method
+		     (subtypep (ecase accessor-type
+				 ((reader) (car classes))
+				 ((writer) (cadr classes)))
+			       class))
+	    (return-from break-vicious-metacircle
+	      (values index (list method) type index)))))))
+  (error "~@<vicious metacircle:  The computation of an ~
+	  effective method of ~s for arguments of types ~s uses ~
+	  the effective method being computed.~@:>"
+	 gf classes))
+
+;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic
+;;; function GF accesses a slot of some class in *STANDARD-CLASSES*.
+;;; CLASS is the class accessed, SLOTD is the effective slot definition
+;;; object of the slot accessed, and ACCESSOR-TYPE is one of the symbols
+;;; READER or WRITER describing the slot access.
+(defun accesses-standard-class-slot-p (gf)
+  (flet ((standard-class-slot-access (gf class)
+	   (loop with gf-name = (standard-slot-value/gf gf 'name)
+		 for slotd in (standard-slot-value/class class 'slots)
+		 ;; FIXME: where does BOUNDP fit in here?  Is it
+		 ;; relevant?
+		 as readers = (standard-slot-value/eslotd slotd 'readers)
+		 as writers = (standard-slot-value/eslotd slotd 'writers)
+		 if (member gf-name readers :test #'equal)
+		   return (values slotd 'reader)
+		 else if (member gf-name writers :test #'equal)
+		   return (values slotd 'writer))))
+    (dolist (class-name *standard-classes*)
+      (let ((class (find-class class-name)))
+	(multiple-value-bind (slotd accessor-type)
+	    (standard-class-slot-access gf class)
+	  (when slotd
+	    (return (values class slotd accessor-type))))))))
+
+;;; Find a slot reader/writer method among the methods of generic
+;;; function GF which reads/writes instances of class CLASS.
+;;; TYPE is one of the symbols READER or WRITER.
+(defun find-standard-class-accessor-method (gf class type)
+  (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+	(found-specializer *the-class-t*)
+	(found-method nil))
+    (dolist (method (standard-slot-value/gf gf 'methods) found-method)
+      (let ((specializers (standard-slot-value/method method 'specializers))
+	    (qualifiers (plist-value method 'qualifiers)))
+	(when (and (null qualifiers)
+		   (let ((subcpl (member (ecase type
+					   (reader (car specializers))
+					   (writer (cadr specializers)))
+					 cpl)))
+		     (and subcpl (member found-specializer subcpl))))
+	  (setf found-specializer (ecase type
+				    (reader (car specializers))
+				    (writer (cadr specializers))))
+	  (setf found-method method))))))
 
 (defun accessor-values (gf arg-info classes methods)
   (declare (ignore gf))
   (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
 	 (accessor-class (case accessor-type
-			   (reader (car classes))
-			   (writer (cadr classes))
-			   (boundp (car classes)))))
+			   ((reader boundp) (car classes))
+			   (writer (cadr classes)))))
     (accessor-values-internal accessor-type accessor-class methods)))
 
 (defun accessor-values1 (gf accessor-type accessor-class)
   (let* ((type `(class-eq ,accessor-class))
-	 (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+	 (types (ecase accessor-type
+		  ((reader boundp) `(,type))
+		  (writer `(t ,type))))
 	 (methods (compute-applicable-methods-using-types gf types)))
     (accessor-values-internal accessor-type accessor-class methods)))
 
@@ -1053,8 +1262,10 @@ And so, we are saved.
 			       (early-method-standard-accessor-slot-name meth))
 			  (and (member *the-class-std-object*
 				       (if early-p
-					   (early-class-precedence-list accessor-class)
-					   (class-precedence-list accessor-class)))
+					   (early-class-precedence-list
+					    accessor-class)
+					   (class-precedence-list
+					    accessor-class)))
 			       (if early-p
 				   (not (eq *the-class-standard-method*
 					    (early-method-class meth)))
@@ -1065,7 +1276,8 @@ And so, we are saved.
 	 (slotd (and accessor-class
 		     (if early-p
 			 (dolist (slot (early-class-slotds accessor-class) nil)
-			   (when (eql slot-name (early-slot-definition-name slot))
+			   (when (eql slot-name
+				      (early-slot-definition-name slot))
 			     (return slot)))
 			 (find-slot-definition accessor-class slot-name)))))
     (when (and slotd
@@ -1091,9 +1303,9 @@ And so, we are saved.
       (let* ((specializers (if (consp method)
 			       (early-method-specializers method t)
 			       (method-specializers method)))
-	     (specl (if (eq type 'reader)
-			(car specializers)
-			(cadr specializers)))
+	     (specl (ecase type
+		      ((reader boundp) (car specializers))
+		      (writer (cadr specializers))))
 	     (specl-cpl (if early-p
 			    (early-class-precedence-list specl)
 			    (and (class-finalized-p specl)
@@ -1101,44 +1313,45 @@ And so, we are saved.
 	     (so-p (member *the-class-std-object* specl-cpl))
 	     (slot-name (if (consp method)
 			    (and (early-method-standard-accessor-p method)
-				 (early-method-standard-accessor-slot-name method))
+				 (early-method-standard-accessor-slot-name
+				  method))
 			    (accessor-method-slot-name method))))
 	(when (or (null specl-cpl)
 		  (member *the-class-structure-object* specl-cpl))
 	  (return-from make-accessor-table nil))
-	(maphash #'(lambda (class slotd)
-		     (let ((cpl (if early-p
-				    (early-class-precedence-list class)
-				    (class-precedence-list class))))
-		       (when (memq specl cpl)
-			 (unless (and (or so-p
-					  (member *the-class-std-object* cpl))
-				      (or early-p
-					  (slot-accessor-std-p slotd type)))
-			   (return-from make-accessor-table nil))
-			 (push (cons specl slotd) (gethash class table)))))
+	(maphash (lambda (class slotd)
+		   (let ((cpl (if early-p
+				  (early-class-precedence-list class)
+				  (class-precedence-list class))))
+		     (when (memq specl cpl)
+		       (unless (and (or so-p
+					(member *the-class-std-object* cpl))
+				    (or early-p
+					(slot-accessor-std-p slotd type)))
+			 (return-from make-accessor-table nil))
+		       (push (cons specl slotd) (gethash class table)))))
 		 (gethash slot-name *name->class->slotd-table*))))
-    (maphash #'(lambda (class specl+slotd-list)
-		 (dolist (sclass (if early-p
-				    (early-class-precedence-list class)
-				    (class-precedence-list class))
-			  (error "This can't happen"))
-		   (let ((a (assq sclass specl+slotd-list)))
-		     (when a
-		       (let* ((slotd (cdr a))
-			      (index (if early-p
-					 (early-slot-definition-location slotd)
-					 (slot-definition-location slotd))))
-			 (unless index (return-from make-accessor-table nil))
-			 (setf (gethash class table) index)
-			 (when (consp index) (setq no-class-slots-p nil))
-			 (setq all-index (if (or (null all-index)
-						 (eql all-index index))
-					     index t))
-			 (incf size)
-			 (cond ((= size 1) (setq first class))
-			       ((= size 2) (setq second class)))
-			 (return nil))))))
+    (maphash (lambda (class specl+slotd-list)
+	       (dolist (sclass (if early-p
+				   (early-class-precedence-list class)
+				   (class-precedence-list class))
+			       (error "This can't happen."))
+		 (let ((a (assq sclass specl+slotd-list)))
+		   (when a
+		     (let* ((slotd (cdr a))
+			    (index (if early-p
+				       (early-slot-definition-location slotd)
+				       (slot-definition-location slotd))))
+		       (unless index (return-from make-accessor-table nil))
+		       (setf (gethash class table) index)
+		       (when (consp index) (setq no-class-slots-p nil))
+		       (setq all-index (if (or (null all-index)
+					       (eql all-index index))
+					   index t))
+		       (incf size)
+		       (cond ((= size 1) (setq first class))
+			     ((= size 2) (setq second class)))
+		       (return nil))))))
 	     table)
     (values table all-index first second size no-class-slots-p)))
 
@@ -1164,8 +1377,10 @@ And so, we are saved.
 	  (unless applicable-p (setq definite-p nil))
 	  (push method possibly-applicable-methods))))
     (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
-					       (early-gf-arg-info generic-function)
-					       (gf-arg-info generic-function)))))
+					       (early-gf-arg-info
+						generic-function)
+					       (gf-arg-info
+						generic-function)))))
       (values (sort-applicable-methods precedence
 				       (nreverse possibly-applicable-methods)
 				       types)
@@ -1174,22 +1389,24 @@ And so, we are saved.
 (defun sort-applicable-methods (precedence methods types)
   (sort-methods methods
 		precedence
-		#'(lambda (class1 class2 index)
-		    (let* ((class (type-class (nth index types)))
-			   (cpl (if (eq *boot-state* 'complete)
-				    (class-precedence-list class)
-				    (early-class-precedence-list class))))
-		      (if (memq class2 (memq class1 cpl))
-			  class1 class2)))))
+		(lambda (class1 class2 index)
+		  (let* ((class (type-class (nth index types)))
+			 (cpl (if (eq *boot-state* 'complete)
+				  (class-precedence-list class)
+				  (early-class-precedence-list class))))
+		    (if (memq class2 (memq class1 cpl))
+			class1 class2)))))
 
 (defun sort-methods (methods precedence compare-classes-function)
   (flet ((sorter (method1 method2)
 	   (dolist (index precedence)
 	     (let* ((specl1 (nth index (if (listp method1)
-					   (early-method-specializers method1 t)
+					   (early-method-specializers method1
+								      t)
 					   (method-specializers method1))))
 		    (specl2 (nth index (if (listp method2)
-					   (early-method-specializers method2 t)
+					   (early-method-specializers method2
+								      t)
 					   (method-specializers method2))))
 		    (order (order-specializers
 			     specl1 specl2 index compare-classes-function)))
@@ -1213,10 +1430,12 @@ And so, we are saved.
 	  (t
 	   (case (car type1)
 	     (class    (case (car type2)
-			 (class (funcall compare-classes-function specl1 specl2 index))
+			 (class (funcall compare-classes-function
+					 specl1 specl2 index))
 			 (t specl2)))
 	     (prototype (case (car type2)
-			 (class (funcall compare-classes-function specl1 specl2 index))
+			 (class (funcall compare-classes-function
+					 specl1 specl2 index))
 			 (t specl2)))
 	     (class-eq (case (car type2)
 			 (eql specl2)
@@ -1247,7 +1466,10 @@ And so, we are saved.
 			       (list class2 class1 t)
 			       (let ((name1 (class-name class1))
 				     (name2 (class-name class2)))
-				 (if (and name1 name2 (symbolp name1) (symbolp name2)
+				 (if (and name1
+					  name2
+					  (symbolp name1)
+					  (symbolp name2)
 					  (string< (symbol-name name1)
 						   (symbol-name name2)))
 				     (list class1 class2 t)
@@ -1255,16 +1477,16 @@ And so, we are saved.
 		 (push choice choices))
 	       (car choice))))
       (loop (funcall function
-		     (sort-methods methods precedence #'compare-classes-function))
+		     (sort-methods methods
+				   precedence
+				   #'compare-classes-function))
 	    (unless (dolist (c choices nil)
 		      (unless (third c)
 			(rotatef (car c) (cadr c))
 			(return (setf (third c) t))))
 	      (return nil))))))
 
-(defvar *in-precompute-effective-methods-p* nil)
-
-;used only in map-all-orders
+;;; CMUCL comment: used only in map-all-orders
 (defun class-might-precede-p (class1 class2)
   (if (not *in-precompute-effective-methods-p*)
       (not (member class1 (cdr (class-precedence-list class2))))
@@ -1277,6 +1499,25 @@ And so, we are saved.
       (mapcar (lambda (x) (position x lambda-list))
 	      argument-precedence-order)))
 
+(defun cpl-or-nil (class)
+  (if (eq *boot-state* 'complete)
+      ;; KLUDGE: why not use (slot-boundp class
+      ;; 'class-precedence-list)?  Well, unfortunately, CPL-OR-NIL is
+      ;; used within COMPUTE-APPLICABLE-METHODS, including for
+      ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for
+      ;; breaking such nasty cycles in effective method computation
+      ;; only works for readers and writers, not boundps.  It might
+      ;; not be too hard to make it work for BOUNDP accessors, but in
+      ;; the meantime we use an extra slot for exactly the result of
+      ;; the SLOT-BOUNDP that we want.  (We cannot use
+      ;; CLASS-FINALIZED-P, because in the process of class
+      ;; finalization we need to use the CPL which has been computed
+      ;; to cache effective methods for slot accessors.) -- CSR,
+      ;; 2004-09-19.
+      (when (cpl-available-p class)
+        (class-precedence-list class))
+      (early-class-precedence-list class)))
+
 (defun saut-and (specl type)
   (let ((applicable nil)
 	(possibly-applicable t))
@@ -1300,8 +1541,8 @@ And so, we are saved.
 
 (defun saut-not-class (specl ntype)
   (let* ((class (type-class specl))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+	 (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-prototype (specl ntype)
   (let* ((class (case (car specl)
@@ -1309,8 +1550,8 @@ And so, we are saved.
 		  (class-eq  (cadr specl))
 		  (prototype (cadr specl))
 		  (class     (cadr specl))))
-	 (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
+	 (cpl (cpl-or-nil class)))
+    (not (memq (cadr ntype) cpl))))
 
 (defun saut-not-class-eq (specl ntype)
   (let ((class (case (car specl)
@@ -1324,9 +1565,7 @@ And so, we are saved.
     (t   t)))
 
 (defun class-applicable-using-class-p (specl type)
-  (let ((pred (memq specl (if (eq *boot-state* 'complete)
-			      (class-precedence-list type)
-			      (early-class-precedence-list type)))))
+  (let ((pred (memq specl (cpl-or-nil type))))
     (values pred
 	    (or pred
 		(if (not *in-precompute-effective-methods-p*)
@@ -1348,7 +1587,7 @@ And so, we are saved.
     (class (class-applicable-using-class-p (cadr specl) (cadr type)))
     (t     (values nil (let ((class (type-class specl)))
 			 (memq (cadr type)
-			       (class-precedence-list class)))))))
+			       (cpl-or-nil class)))))))
 
 (defun saut-class-eq (specl type)
   (if (eq (car specl) 'eql)
@@ -1358,15 +1597,12 @@ And so, we are saved.
 		     (eq (cadr specl) (cadr type)))
 		    (class
 		     (or (eq (cadr specl) (cadr type))
-			 (memq (cadr specl)
-			       (if (eq *boot-state* 'complete)
-				   (class-precedence-list (cadr type))
-				   (early-class-precedence-list (cadr type)))))))))
+			 (memq (cadr specl) (cpl-or-nil (cadr type))))))))
 	(values pred pred))))
 
 (defun saut-prototype (specl type)
   (declare (ignore specl type))
-  (values nil nil)) ; fix this someday
+  (values nil nil)) ; XXX original PCL comment: fix this someday
 
 (defun saut-eql (specl type)
   (let ((pred (case (car specl)
@@ -1374,18 +1610,16 @@ And so, we are saved.
 		(class-eq   (eq (cadr specl) (class-of (cadr type))))
 		(class      (memq (cadr specl)
 				  (let ((class (class-of (cadr type))))
-				    (if (eq *boot-state* 'complete)
-					(class-precedence-list class)
-					(early-class-precedence-list class))))))))
+				    (cpl-or-nil class)))))))
     (values pred pred)))
 
 (defun specializer-applicable-using-type-p (specl type)
   (setq specl (type-from-specializer specl))
-  (when (eq specl 't)
+  (when (eq specl t)
     (return-from specializer-applicable-using-type-p (values t t)))
-  ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
+  ;; This is used by C-A-M-U-T and GENERATE-DISCRIMINATION-NET-INTERNAL,
   ;; and has only what they need.
-  (if (or (atom type) (eq (car type) 't))
+  (if (or (atom type) (eq (car type) t))
       (values nil t)
       (case (car type)
 	(and	(saut-and specl type))
@@ -1398,7 +1632,7 @@ And so, we are saved.
 			   'specializer-applicable-using-type-p
 			   type)))))
 
-(defun map-all-classes (function &optional (root 't))
+(defun map-all-classes (function &optional (root t))
   (let ((braid-p (or (eq *boot-state* 'braid)
 		     (eq *boot-state* 'complete))))
     (labels ((do-class (class)
@@ -1411,43 +1645,39 @@ And so, we are saved.
 		    (find-class root)
 		    root)))))
 
-;;; NOTE: We are assuming a restriction on user code that the method
-;;;       combination must not change once it is connected to the
-;;;       generic function.
-;;;
-;;;       This has to be legal, because otherwise any kind of method
-;;;       lookup caching couldn't work. See this by saying that this
-;;;       cache, is just a backing cache for the fast cache. If that
-;;;       cache is legal, this one must be too.
-;;;
-;;; Don't clear this table!
-(defvar *effective-method-table* (make-hash-table :test 'eq))
-
-(defun get-secondary-dispatch-function (gf methods types &optional
-							 method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1
-		     gf methods types
-		     (not (null method-alist))
-		     (not (null wrappers))
-		     (not (methods-contain-eql-specializer-p methods)))
-		    method-alist wrappers))
-
-(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p
-					    &optional all-applicable-p
-					    (all-sorted-p t) function-p)
+(defvar *effective-method-cache* (make-hash-table :test 'eq))
+
+(defun flush-effective-method-cache (generic-function)
+  (dolist (method (generic-function-methods generic-function))
+    (remhash method *effective-method-cache*)))
+
+(defun get-secondary-dispatch-function (gf methods types
+					&optional method-alist wrappers)
+  (let ((generator
+	 (get-secondary-dispatch-function1
+	  gf methods types (not (null method-alist)) (not (null wrappers))
+	  (not (methods-contain-eql-specializer-p methods)))))
+    (make-callable gf methods generator method-alist wrappers)))
+
+(defun get-secondary-dispatch-function1 (gf methods types method-alist-p
+					    wrappers-p
+					    &optional
+					    all-applicable-p
+					    (all-sorted-p t)
+					    function-p)
   (if (null methods)
       (if function-p
-	  #'(lambda (method-alist wrappers)
-	      (declare (ignore method-alist wrappers))
-	      #'(sb-kernel:instance-lambda (&rest args)
-		  (apply #'no-applicable-method gf args)))
-	  #'(lambda (method-alist wrappers)
-	      (declare (ignore method-alist wrappers))
-	      #'(lambda (&rest args)
-		  (apply #'no-applicable-method gf args))))
+	  (lambda (method-alist wrappers)
+	    (declare (ignore method-alist wrappers))
+	    #'(instance-lambda (&rest args)
+		(apply #'no-applicable-method gf args)))
+	  (lambda (method-alist wrappers)
+	    (declare (ignore method-alist wrappers))
+	    (lambda (&rest args)
+	      (apply #'no-applicable-method gf args))))
       (let* ((key (car methods))
-	     (ht-value (or (gethash key *effective-method-table*)
-			   (setf (gethash key *effective-method-table*)
+	     (ht-value (or (gethash key *effective-method-cache*)
+			   (setf (gethash key *effective-method-cache*)
 				 (cons nil nil)))))
 	(if (and (null (cdr methods)) all-applicable-p ; the most common case
 		 (null method-alist-p) wrappers-p (not function-p))
@@ -1466,25 +1696,28 @@ And so, we are saved.
 		    (push (cons akey value) (cdr ht-value))
 		    value)))))))
 
-(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p
-					    all-applicable-p all-sorted-p function-p)
+(defun get-secondary-dispatch-function2 (gf methods types method-alist-p
+					    wrappers-p all-applicable-p
+					    all-sorted-p function-p)
   (if (and all-applicable-p all-sorted-p (not function-p))
       (if (eq *boot-state* 'complete)
 	  (let* ((combin (generic-function-method-combination gf))
 		 (effective (compute-effective-method gf combin methods)))
-	    (make-effective-method-function1 gf effective method-alist-p wrappers-p))
+	    (make-effective-method-function1 gf effective method-alist-p
+					     wrappers-p))
 	  (let ((effective (standard-compute-effective-method gf nil methods)))
-	    (make-effective-method-function1 gf effective method-alist-p wrappers-p)))
+	    (make-effective-method-function1 gf effective method-alist-p
+					     wrappers-p)))
       (let ((net (generate-discrimination-net
 		  gf methods types all-sorted-p)))
 	(compute-secondary-dispatch-function1 gf net function-p))))
 
-(defun get-effective-method-function (gf methods &optional method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1 gf methods nil
-						      (not (null method-alist))
-						      (not (null wrappers))
-						      t)
-		    method-alist wrappers))
+(defun get-effective-method-function (gf methods
+					 &optional method-alist wrappers)
+  (let ((generator
+	 (get-secondary-dispatch-function1
+	  gf methods nil (not (null method-alist)) (not (null wrappers)) t)))
+    (make-callable gf methods generator method-alist wrappers)))
 
 (defun get-effective-method-function1 (gf methods &optional (sorted-p t))
   (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
@@ -1500,26 +1733,24 @@ And so, we are saved.
   (let* ((early-p (early-gf-p generic-function))
 	 (gf-name (if early-p
 		      (!early-gf-name generic-function)
-		      (generic-function-name generic-function)))
-	 (ocache (gf-dfun-cache generic-function)))
+		      (generic-function-name generic-function))))
     (set-dfun generic-function dfun cache info)
-    (let* ((dfun (if early-p
-		     (or dfun (make-initial-dfun generic-function))
-		     (compute-discriminating-function generic-function)))
-	   (info (gf-dfun-info generic-function)))
-      (unless (eq 'default-method-only (type-of info))
-	(setq dfun (doctor-dfun-for-the-debugger
-		    generic-function
-		    dfun)))
+    (let ((dfun (if early-p
+		    (or dfun (make-initial-dfun generic-function))
+		    (compute-discriminating-function generic-function))))
       (set-funcallable-instance-function generic-function dfun)
-      (set-function-name generic-function gf-name)
-      (when (and ocache (not (eq ocache cache))) (free-cache ocache))
+      (set-fun-name generic-function gf-name)
       dfun)))
 
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)
 (defvar *minimum-cache-size-to-list*)
 
+;;; These functions aren't used in SBCL, or documented anywhere that
+;;; I'm aware of, but they look like they might be useful for
+;;; debugging or performance tweaking or something, so I've just
+;;; commented them out instead of deleting them. -- WHN 2001-03-28
+#|
 (defun list-dfun (gf)
   (let* ((sym (type-of (gf-dfun-info gf)))
 	 (a (assq sym *dfun-list*)))
@@ -1548,7 +1779,7 @@ And so, we are saved.
 (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130))
   (setq *dfun-list* nil)
   (map-all-generic-functions #'list-large-cache)
-  (setq *dfun-list* (sort dfun-list #'< :key #'car))
+  (setq *dfun-list* (sort *dfun-list* #'< :key #'car))
   (mapc #'print *dfun-list*)
   (values))
 
@@ -1567,26 +1798,28 @@ And so, we are saved.
 	(incf (cdr b))))))
 
 (defun count-all-dfuns ()
-  (setq *dfun-count* (mapcar #'(lambda (type) (list type 0 nil))
+  (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil))
 			     '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY
 			       ONE-INDEX N-N CHECKING CACHING
 			       DISPATCH)))
   (map-all-generic-functions #'count-dfun)
-  (mapc #'(lambda (type+count+sizes)
-	    (setf (third type+count+sizes)
-		  (sort (third type+count+sizes) #'< :key #'car)))
+  (mapc (lambda (type+count+sizes)
+	  (setf (third type+count+sizes)
+		(sort (third type+count+sizes) #'< :key #'car)))
 	*dfun-count*)
-  (mapc #'(lambda (type+count+sizes)
-	    (format t "~&There are ~D dfuns of type ~S."
-		    (cadr type+count+sizes) (car type+count+sizes))
-	    (format t "~%   ~S~%" (caddr type+count+sizes)))
+  (mapc (lambda (type+count+sizes)
+	  (format t "~&There are ~W dfuns of type ~S."
+		  (cadr type+count+sizes) (car type+count+sizes))
+	  (format t "~%   ~S~%" (caddr type+count+sizes)))
 	*dfun-count*)
   (values))
+|#
 
 (defun gfs-of-type (type)
   (unless (consp type) (setq type (list type)))
   (let ((gf-list nil))
-    (map-all-generic-functions #'(lambda (gf)
-				   (when (memq (type-of (gf-dfun-info gf)) type)
-				     (push gf gf-list))))
+    (map-all-generic-functions (lambda (gf)
+				 (when (memq (type-of (gf-dfun-info gf))
+					     type)
+				   (push gf gf-list))))
     gf-list))