Simplify (and robustify) regular PACKing

[sbcl.git] / src / pcl / dfun.lisp

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 51bcea8..7fe8491 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -181,24 +181,27 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; lookup machinery.
 
 (defvar *standard-classes*
 ;;; lookup machinery.
 
 (defvar *standard-classes*

+  ;; KLUDGE: order matters!  finding effective slot definitions
+  ;; involves calling slot-definition-name, and we need to do that to
+  ;; break metacycles, so STANDARD-EFFECTIVE-SLOT-DEFINITION must
+  ;; precede STANDARD-DIRECT-SLOT-DEFINITION in this list, at least
+  ;; until ACCESSES-STANDARD-CLASS-SLOT-P is generalized

   '(standard-method standard-generic-function standard-class
   '(standard-method standard-generic-function standard-class

-    standard-effective-slot-definition))
+    standard-effective-slot-definition standard-direct-slot-definition))

 
 (defvar *standard-slot-locations* (make-hash-table :test 'equal))
 
 (defun compute-standard-slot-locations ()
 
 (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)
+  (let ((new (make-hash-table :test 'equal)))
+    (dolist (class-name *standard-classes*)
+      (let ((class (find-class class-name)))
+        (dolist (slot (class-slots class))
+          (setf (gethash (cons class (slot-definition-name slot)) new)
+                (slot-definition-location slot)))))
+    (setf *standard-slot-locations* new)))
+
+(defun maybe-update-standard-slot-locations (class)
+  (when (and (eq **boot-state** 'complete)

              (memq (class-name class) *standard-classes*))
     (compute-standard-slot-locations)))
 
              (memq (class-name class) *standard-classes*))
     (compute-standard-slot-locations)))
 

@@ -226,6 +229,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (standard-slot-value slotd slot-name
                        *the-class-standard-effective-slot-definition*))
 
   (standard-slot-value slotd slot-name
                        *the-class-standard-effective-slot-definition*))
 

+(defun standard-slot-value/dslotd (slotd slot-name)
+  (standard-slot-value slotd slot-name
+                       *the-class-standard-direct-slot-definition*))
+

 (defun standard-slot-value/class (class slot-name)
   (standard-slot-value class slot-name *the-class-standard-class*))
 \f
 (defun standard-slot-value/class (class slot-name)
   (standard-slot-value class slot-name *the-class-standard-class*))
 \f

@@ -260,8 +267,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;;     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
 ;;;     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.
+;;;     and corresponding slot indexes.
+

 (defstruct (dfun-info (:constructor nil)
                       (:copier nil))
   (cache nil))
 (defstruct (dfun-info (:constructor nil)
                       (:copier nil))
   (cache nil))

@@ -274,10 +281,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                     (:include dfun-info)
                     (:copier nil)))
 
                     (:include dfun-info)
                     (:copier nil)))
 

-(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ())
-                             (:include dfun-info)
-                             (:copier nil)))
-

 (defstruct (dispatch (:constructor dispatch-dfun-info ())
                      (:include dfun-info)
                      (:copier nil)))
 (defstruct (dispatch (:constructor dispatch-dfun-info ())
                      (:include dfun-info)
                      (:copier nil)))

@@ -401,7 +404,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                  (reader 'emit-one-index-readers)
                  (boundp 'emit-one-index-boundps)
                  (writer 'emit-one-index-writers)))
                  (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)))
+         (cache (or cache (make-cache :key-count 1 :value nil :size 4)))

          (dfun-info (one-index-dfun-info type index cache)))
     (declare (type cache cache))
     (values
          (dfun-info (one-index-dfun-info type index cache)))
     (declare (type cache cache))
     (values

@@ -412,19 +415,12 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
      cache
      dfun-info)))
 
      cache
      dfun-info)))
 

-(defun make-final-one-index-accessor-dfun (gf type index table)
-  (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
-    (make-one-index-accessor-dfun gf type index cache)))
-
-(defun one-index-limit-fn (nlines)
-  (default-limit-fn nlines))
-

 (defun make-n-n-accessor-dfun (gf type &optional cache)
   (let* ((emit (ecase type
                  (reader 'emit-n-n-readers)
                  (boundp 'emit-n-n-boundps)
                  (writer 'emit-n-n-writers)))
 (defun make-n-n-accessor-dfun (gf type &optional cache)
   (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)))
+         (cache (or cache (make-cache :key-count 1 :value t :size 2)))

          (dfun-info (n-n-dfun-info type cache)))
     (declare (type cache cache))
     (values
          (dfun-info (n-n-dfun-info type cache)))
     (declare (type cache cache))
     (values

@@ -434,13 +430,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
      cache
      dfun-info)))
 
      cache
      dfun-info)))
 

-(defun make-final-n-n-accessor-dfun (gf type table)
-  (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
-    (make-n-n-accessor-dfun gf type cache)))
-
-(defun n-n-accessors-limit-fn (nlines)
-  (default-limit-fn nlines))
-

 (defun make-checking-dfun (generic-function function &optional cache)
   (unless cache
     (when (use-caching-dfun-p generic-function)
 (defun make-checking-dfun (generic-function function &optional cache)
   (unless cache
     (when (use-caching-dfun-p generic-function)

@@ -457,7 +446,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                     function)
            nil
            dfun-info))
                     function)
            nil
            dfun-info))

-        (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
+        (let* ((cache (or cache (make-cache :key-count nkeys :value nil :size 2)))

                (dfun-info (checking-dfun-info function cache)))
           (values
            (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
                (dfun-info (checking-dfun-info function cache)))
           (values
            (funcall (get-dfun-constructor 'emit-checking metatypes applyp)

@@ -468,16 +457,16 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            cache
            dfun-info)))))
 
            cache
            dfun-info)))))
 

-(defun make-final-checking-dfun (generic-function function
-                                                  classes-list new-class)
-  (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
+(defun make-final-checking-dfun (generic-function function classes-list new-class)
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-fun-info generic-function)
+    (declare (ignore nreq applyp nkeys))

     (if (every (lambda (mt) (eq mt t)) metatypes)
         (values (lambda (&rest args)
                   (invoke-emf function args))
                 nil (default-method-only-dfun-info))
     (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
-                      classes-list new-class)))
+        (let ((cache (make-final-ordinary-dfun-cache
+                      generic-function nil classes-list new-class)))

           (make-checking-dfun generic-function function cache)))))
 
 (defun use-default-method-only-dfun-p (generic-function)
           (make-checking-dfun generic-function function cache)))))
 
 (defun use-default-method-only-dfun-p (generic-function)

@@ -487,11 +476,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (every (lambda (mt) (eq mt t)) metatypes)))
 
 (defun use-caching-dfun-p (generic-function)
     (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)))
+  (some (lambda (method) (method-plist-value method :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
         ;; 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

@@ -502,9 +487,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
              (if (early-gf-p generic-function)
                  (early-gf-methods generic-function)
                  (generic-function-methods generic-function)))))
              (if (early-gf-p generic-function)
                  (early-gf-methods generic-function)
                  (generic-function-methods generic-function)))))

-
-(defun checking-limit-fn (nlines)
-  (default-limit-fn nlines))

 \f
 (defun make-caching-dfun (generic-function &optional cache)
   (unless cache
 \f
 (defun make-caching-dfun (generic-function &optional cache)
   (unless cache

@@ -517,7 +499,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info generic-function)
     (declare (ignore nreq))
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info generic-function)
     (declare (ignore nreq))

-    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+    (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2)))

            (dfun-info (caching-dfun-info cache)))
       (values
        (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
            (dfun-info (caching-dfun-info cache)))
       (values
        (funcall (get-dfun-constructor 'emit-caching metatypes applyp)

@@ -528,14 +510,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
        dfun-info))))
 
 (defun make-final-caching-dfun (generic-function classes-list new-class)
        dfun-info))))
 
 (defun make-final-caching-dfun (generic-function classes-list new-class)

-  (let ((cache (make-final-ordinary-dfun-internal
-                generic-function t #'caching-limit-fn
-                classes-list new-class)))
+  (let ((cache (make-final-ordinary-dfun-cache
+                generic-function t classes-list new-class)))

     (make-caching-dfun generic-function cache)))
 
     (make-caching-dfun generic-function cache)))
 

-(defun caching-limit-fn (nlines)
-  (default-limit-fn nlines))
-

 (defun insure-caching-dfun (gf)
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info gf)
 (defun insure-caching-dfun (gf)
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info gf)

@@ -556,7 +534,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                         (generic-function-methods gf)))
            (default '(unknown)))
       (and (null applyp)
                         (generic-function-methods gf)))
            (default '(unknown)))
       (and (null applyp)

-           (or (not (eq *boot-state* 'complete))
+           (or (not (eq **boot-state** 'complete))

                ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
                ;; can't use this, of course, because we can't tell
                ;; which methods will be considered applicable.
                ;; If COMPUTE-APPLICABLE-METHODS is specialized, we
                ;; can't use this, of course, because we can't tell
                ;; which methods will be considered applicable.

@@ -577,17 +555,12 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            ;; method has qualifiers, to make sure that emfs are really
            ;; method functions; see above.
            (dolist (method methods t)
            ;; method has qualifiers, to make sure that emfs are really
            ;; method functions; see above.
            (dolist (method methods t)

-             (when (eq *boot-state* 'complete)
+             (when (eq **boot-state** 'complete)

                (when (or (some #'eql-specializer-p
                (when (or (some #'eql-specializer-p

-                               (method-specializers method))
-                         (method-qualifiers method))
+                               (safe-method-specializers method))
+                         (safe-method-qualifiers method))

                  (return nil)))
                  (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)))
+             (let ((value (method-plist-value method :constant-value default)))

                (when (or (eq value default)
                          (and boolean-values-p
                               (not (member value '(t nil)))))
                (when (or (eq value default)
                          (and boolean-values-p
                               (not (member value '(t nil)))))

@@ -597,8 +570,9 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info generic-function)
     (declare (ignore nreq applyp))
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-fun-info generic-function)
     (declare (ignore nreq applyp))

-    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+    (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2)))

            (dfun-info (constant-value-dfun-info cache)))
            (dfun-info (constant-value-dfun-info cache)))

+      (declare (type cache cache))

       (values
        (funcall (get-dfun-constructor 'emit-constant-value metatypes)
                 cache
       (values
        (funcall (get-dfun-constructor 'emit-constant-value metatypes)
                 cache

@@ -608,15 +582,24 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
        dfun-info))))
 
 (defun make-final-constant-value-dfun (generic-function classes-list new-class)
        dfun-info))))
 
 (defun make-final-constant-value-dfun (generic-function classes-list new-class)

-  (let ((cache (make-final-ordinary-dfun-internal
-                generic-function :constant-value #'caching-limit-fn
-                classes-list new-class)))
+  (let ((cache (make-final-ordinary-dfun-cache
+                generic-function :constant-value classes-list new-class)))

     (make-constant-value-dfun generic-function cache)))
 
     (make-constant-value-dfun generic-function cache)))
 

+(defun gf-has-method-with-nonstandard-specializer-p (gf)
+  (let ((methods (generic-function-methods gf)))
+    (dolist (method methods nil)
+      (unless (every (lambda (s) (standard-specializer-p s))
+                     (method-specializers method))
+        (return t)))))
+

 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))

-  (when (eq *boot-state* 'complete)
+  (when (eq **boot-state** 'complete)

     (unless (or caching-p
     (unless (or caching-p

-                (gf-requires-emf-keyword-checks gf))
+                (gf-requires-emf-keyword-checks gf)
+                ;; DISPATCH-DFUN-COST will error if it encounters a
+                ;; method with a non-standard specializer.
+                (gf-has-method-with-nonstandard-specializer-p 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
       ;; 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

@@ -631,9 +614,9 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
       (let ((cdc  (caching-dfun-cost gf))) ; fast
         (> cdc (dispatch-dfun-cost gf cdc))))))
 
       (let ((cdc  (caching-dfun-cost gf))) ; fast
         (> cdc (dispatch-dfun-cost gf cdc))))))
 

-(defparameter *non-built-in-typep-cost* 1)
-(defparameter *structure-typep-cost* 1)
-(defparameter *built-in-typep-cost* 0)
+(defparameter *non-built-in-typep-cost* 100)
+(defparameter *structure-typep-cost*  15)
+(defparameter *built-in-typep-cost* 5)

 
 ;;; According to comments in the original CMU CL version of PCL,
 ;;; the cost LIMIT is important to cut off exponential growth for
 
 ;;; According to comments in the original CMU CL version of PCL,
 ;;; the cost LIMIT is important to cut off exponential growth for

@@ -664,13 +647,12 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
        max-cost-so-far))
    #'identity))
 
        max-cost-so-far))
    #'identity))
 

-(defparameter *cache-lookup-cost* 1)
-(defparameter *wrapper-of-cost* 0)
-(defparameter *secondary-dfun-call-cost* 1)
+(defparameter *cache-lookup-cost*  30)
+(defparameter *wrapper-of-cost* 15)
+(defparameter *secondary-dfun-call-cost* 30)

 
 (defun caching-dfun-cost (gf)
 
 (defun caching-dfun-cost (gf)

-  (let* ((arg-info (gf-arg-info gf))
-         (nreq (length (arg-info-metatypes arg-info))))
+  (let ((nreq (get-generic-fun-info gf)))

     (+ *cache-lookup-cost*
        (* *wrapper-of-cost* nreq)
        (if (methods-contain-eql-specializer-p
     (+ *cache-lookup-cost*
        (* *wrapper-of-cost* nreq)
        (if (methods-contain-eql-specializer-p

@@ -678,13 +660,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            *secondary-dfun-call-cost*
            0))))
 
            *secondary-dfun-call-cost*
            0))))
 

-(setq *non-built-in-typep-cost* 100)
-(setq *structure-typep-cost* 15)
-(setq *built-in-typep-cost* 5)
-(setq *cache-lookup-cost* 30)
-(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)
 (declaim (inline make-callable))
 (defun make-callable (gf methods generator method-alist wrappers)
   (let* ((*applicable-methods* methods)

@@ -704,21 +679,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (make-dispatch-dfun gf))
 
 (defun update-dispatch-dfuns ()
   (make-dispatch-dfun gf))
 
 (defun update-dispatch-dfuns ()

-  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
+  (dolist (gf (gfs-of-type '(dispatch)))

     (dfun-update gf #'make-dispatch-dfun)))
 
     (dfun-update gf #'make-dispatch-dfun)))
 

-(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)))
-             table)
-    cache))
-
-(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
-                                                           classes-list new-class)
+(defun make-final-ordinary-dfun-cache
+    (generic-function valuep classes-list new-class)

   (let* ((arg-info (gf-arg-info generic-function))
          (nkeys (arg-info-nkeys arg-info))
          (new-class (and new-class
   (let* ((arg-info (gf-arg-info generic-function))
          (nkeys (arg-info-nkeys arg-info))
          (new-class (and new-class

@@ -729,8 +694,9 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                          new-class))
          (cache (if new-class
                     (copy-cache (gf-dfun-cache generic-function))
                          new-class))
          (cache (if new-class
                     (copy-cache (gf-dfun-cache generic-function))

-                    (get-cache nkeys (not (null valuep)) limit-fn 4))))
-      (make-emf-cache generic-function valuep cache classes-list new-class)))
+                    (make-cache :key-count nkeys :value (not (null valuep))
+                                :size 4))))
+    (make-emf-cache generic-function valuep cache classes-list new-class)))

 \f
 (defvar *dfun-miss-gfs-on-stack* ())
 
 \f
 (defvar *dfun-miss-gfs-on-stack* ())
 

@@ -771,63 +737,21 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
 
 (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)
 (defun make-initial-dfun (gf)

-  (let ((initial-dfun
-         #'(lambda (&rest args)
-             (initial-dfun gf args))))
+  (let ((initial-dfun #'(lambda (&rest args) (initial-dfun gf args))))

     (multiple-value-bind (dfun cache info)
     (multiple-value-bind (dfun cache 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))))))
+        (if (eq **boot-state** 'complete)
+            (values initial-dfun nil (initial-dfun-info))
+            (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)
       (set-dfun gf dfun cache info))))
 
 (defun make-early-accessor (gf type)

@@ -858,8 +782,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           ((use-caching-dfun-p gf)
            (dfun-update gf #'make-caching-dfun))
           (t
           ((use-caching-dfun-p gf)
            (dfun-update gf #'make-caching-dfun))
           (t

-           (dfun-update
-            gf #'make-checking-dfun
+           (dfun-update gf #'make-checking-dfun

             ;; nemf is suitable only for caching, have to do this:
             (cache-miss-values gf args 'checking))))))
 
             ;; nemf is suitable only for caching, have to do this:
             (cache-miss-values gf args 'checking))))))
 

@@ -868,51 +791,47 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
       (make-final-dfun-internal gf classes-list)
     (set-dfun gf dfun cache info)))
 
       (make-final-dfun-internal gf classes-list)
     (set-dfun gf dfun cache info)))
 

+;;; FIXME: What is this?

 (defvar *new-class* nil)
 
 (defvar *new-class* nil)
 

-(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
-
-(defmacro with-hash-table ((table test) &body forms)
-  `(let* ((.free. (assoc ',test *free-hash-tables*))
-          (,table (if (cdr .free.)
-                      (pop (cdr .free.))
-                      (make-hash-table :test ',test))))
-     (multiple-value-prog1
-         (progn ,@forms)
-       (clrhash ,table)
-       (push ,table (cdr .free.)))))
-
-(defmacro with-eq-hash-table ((table) &body forms)
-  `(with-hash-table (,table eq) ,@forms))
-

 (defun final-accessor-dfun-type (gf)
   (let ((methods (if (early-gf-p gf)
                      (early-gf-methods gf)
                      (generic-function-methods gf))))
     (cond ((every (lambda (method)
                     (if (consp method)
 (defun final-accessor-dfun-type (gf)
   (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)))
+                        (let ((class (early-method-class method)))
+                          (or (eq class *the-class-standard-reader-method*)
+                              (eq class *the-class-global-reader-method*)))
+                        (or (standard-reader-method-p method)
+                            (global-reader-method-p method))))

                   methods)
            'reader)
           ((every (lambda (method)
                     (if (consp method)
                   methods)
            'reader)
           ((every (lambda (method)
                     (if (consp method)

-                        (eq *the-class-standard-boundp-method*
-                            (early-method-class method))
-                        (standard-boundp-method-p method)))
+                        (let ((class (early-method-class method)))
+                          (or (eq class *the-class-standard-boundp-method*)
+                              (eq class *the-class-global-boundp-method*)))
+                        (or (standard-boundp-method-p method)
+                            (global-boundp-method-p method))))

                   methods)
            'boundp)
           ((every (lambda (method)
                     (if (consp method)
                   methods)
            'boundp)
           ((every (lambda (method)
                     (if (consp method)

-                        (eq *the-class-standard-writer-method*
-                            (early-method-class method))
-                        (standard-writer-method-p method)))
+                        (let ((class (early-method-class method)))
+                          (or (eq class *the-class-standard-writer-method*)
+                              (eq class *the-class-global-writer-method*)))
+                        (and
+                         (or (standard-writer-method-p method)
+                             (global-writer-method-p method))
+                         (not (safe-p
+                               (slot-definition-class
+                                (accessor-method-slot-definition method)))))))

                   methods)
            'writer))))
 
 (defun make-final-accessor-dfun (gf type &optional classes-list new-class)
                   methods)
            'writer))))
 
 (defun make-final-accessor-dfun (gf type &optional classes-list new-class)

-  (with-eq-hash-table (table)
+  (let ((table (make-hash-table :test #'eq)))

     (multiple-value-bind (table all-index first second size no-class-slots-p)
         (make-accessor-table gf type table)
       (if table
     (multiple-value-bind (table all-index first second size no-class-slots-p)
         (make-accessor-table gf type table)
       (if table

@@ -924,10 +843,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                        (w1 (class-wrapper second)))
                    (make-two-class-accessor-dfun gf type w0 w1 all-index)))
                 ((or (integerp all-index) (consp all-index))
                        (w1 (class-wrapper second)))
                    (make-two-class-accessor-dfun gf type w0 w1 all-index)))
                 ((or (integerp all-index) (consp all-index))

-                 (make-final-one-index-accessor-dfun
-                  gf type all-index table))
+                 (let ((cache (hash-table-to-cache table :value nil :key-count 1)))
+                   (make-one-index-accessor-dfun gf type all-index cache)))

                 (no-class-slots-p
                 (no-class-slots-p

-                 (make-final-n-n-accessor-dfun gf type table))
+                 (let ((cache (hash-table-to-cache table :value t :key-count 1)))
+                   (make-n-n-accessor-dfun gf type cache)))

                 (t
                  (make-final-caching-dfun gf classes-list new-class)))
           (make-final-caching-dfun gf classes-list new-class)))))
                 (t
                  (make-final-caching-dfun gf classes-list new-class)))
           (make-final-caching-dfun gf classes-list new-class)))))

@@ -939,7 +859,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (cond ((null methods)
            (values
             #'(lambda (&rest args)
     (cond ((null methods)
            (values
             #'(lambda (&rest args)

-                (apply #'no-applicable-method gf args))
+                (call-no-applicable-method gf args))

             nil
             (no-methods-dfun-info)))
           ((setq type (final-accessor-dfun-type gf))
             nil
             (no-methods-dfun-info)))
           ((setq type (final-accessor-dfun-type gf))

@@ -963,23 +883,23 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           (t
            (make-final-caching-dfun gf classes-list new-class)))))
 
           (t
            (make-final-caching-dfun gf classes-list new-class)))))
 

+(defvar *pcl-misc-random-state* (make-random-state))
+

 (defun accessor-miss (gf new object dfun-info)
   (let* ((ostate (type-of dfun-info))
          (otype (dfun-info-accessor-type dfun-info))
          oindex ow0 ow1 cache
          (args (ecase otype
 (defun accessor-miss (gf new object dfun-info)
   (let* ((ostate (type-of dfun-info))
          (otype (dfun-info-accessor-type dfun-info))
          oindex ow0 ow1 cache
          (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)
                  ((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
       ;; The following lexical functions change the state of the

-      ;; dfun to that which is their name. They accept arguments
+      ;; dfun to that which is their name.  They accept arguments

       ;; which are the parameters of the new state, and get other
       ;; information from the lexical variables bound above.
       (flet ((two-class (index w0 w1)
       ;; which are the parameters of the new state, and get other
       ;; information from the lexical variables bound above.
       (flet ((two-class (index w0 w1)

-               (when (zerop (random 2)) (psetf w0 w1 w1 w0))
+               (when (zerop (random 2 *pcl-misc-random-state*))
+                 (psetf w0 w1 w1 w0))

                (dfun-update gf
                             #'make-two-class-accessor-dfun
                             ntype
                (dfun-update gf
                             #'make-two-class-accessor-dfun
                             ntype

@@ -1003,7 +923,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                (let ((ncache (fill-cache cache wrappers nindex)))
                  (unless (eq ncache cache)
                    (funcall update-fn ncache)))))
                (let ((ncache (fill-cache cache wrappers nindex)))
                  (unless (eq ncache cache)
                    (funcall update-fn ncache)))))

-

         (cond ((null ntype)
                (caching))
               ((or invalidp
         (cond ((null ntype)
                (caching))
               ((or invalidp

@@ -1048,6 +967,9 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (dfun-miss (generic-function args wrappers invalidp nemf)
       (cond (invalidp)
             ((eq oemf nemf)
     (dfun-miss (generic-function args wrappers invalidp nemf)
       (cond (invalidp)
             ((eq oemf nemf)

+             ;; The cache of a checking dfun doesn't hold any values,
+             ;; so this NIL appears to be just a dummy-value we use in
+             ;; order to insert the wrappers into the cache.

              (let ((ncache (fill-cache cache wrappers nil)))
                (unless (eq ncache cache)
                  (dfun-update generic-function #'make-checking-dfun
              (let ((ncache (fill-cache cache wrappers nil)))
                (unless (eq ncache cache)
                  (dfun-update generic-function #'make-checking-dfun

@@ -1069,14 +991,14 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (let ((ocache (dfun-info-cache dfun-info)))
     (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
       (unless invalidp
   (let ((ocache (dfun-info-cache dfun-info)))
     (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
       (unless invalidp

-        (let* ((function
+        (let* ((value

                 (typecase emf
                 (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))
+                  (constant-fast-method-call
+                   (constant-fast-method-call-value emf))
+                  (constant-method-call
+                   (constant-method-call-value emf))
+                  (t
+                   (bug "~S with non-constant EMF ~S" 'constant-value-miss emf))))

                (ncache (fill-cache ocache wrappers value)))
           (unless (eq ncache ocache)
             (dfun-update generic-function
                (ncache (fill-cache ocache wrappers value)))
           (unless (eq ncache ocache)
             (dfun-update generic-function

@@ -1194,17 +1116,32 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; 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)
 ;;; 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))))
+  (labels
+      ((all-dslotds (class &aux done)
+         (labels ((all-dslotds-aux (class)
+                    (if (or (member class done) (not (eq (class-of class) *the-class-standard-class*)))
+                        nil
+                        (progn
+                          (push class done)
+                          (append (standard-slot-value/class class 'direct-slots)
+                                  (mapcan #'(lambda (c)
+                                              (copy-list (all-dslotds-aux c)))
+                                          (standard-slot-value/class class 'direct-superclasses)))))))
+           (all-dslotds-aux class)))
+       (standard-class-slot-access (gf class)
+
+         (loop with gf-name = (standard-slot-value/gf gf 'name)
+            with eslotds = (standard-slot-value/class class 'slots)
+            with dslotds = (all-dslotds class)
+            for dslotd in dslotds
+            as readers = (standard-slot-value/dslotd dslotd 'readers)
+            as writers = (standard-slot-value/dslotd dslotd 'writers)
+            as name = (standard-slot-value/dslotd dslotd 'name)
+            as eslotd = (find name eslotds :key (lambda (x) (standard-slot-value/eslotd x 'name)))
+            if (member gf-name readers :test #'equal)
+            return (values eslotd 'reader)
+            else if (member gf-name writers :test #'equal)
+            return (values eslotd 'writer))))

     (dolist (class-name *standard-classes*)
       (let ((class (find-class class-name)))
         (multiple-value-bind (slotd accessor-type)
     (dolist (class-name *standard-classes*)
       (let ((class (find-class class-name)))
         (multiple-value-bind (slotd accessor-type)

@@ -1216,18 +1153,18 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; 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)
 ;;; 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))
+  (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))
         (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)))
+            (qualifiers (standard-slot-value/method method 'qualifiers)))

         (when (and (null qualifiers)
                    (let ((subcpl (member (ecase type
                                            (reader (car specializers))
                                            (writer (cadr specializers)))
         (when (and (null qualifiers)
                    (let ((subcpl (member (ecase type
                                            (reader (car specializers))
                                            (writer (cadr specializers)))

-                                         cpl)))
-                     (and subcpl (member found-specializer subcpl))))
+                                         cpl :test #'eq)))
+                     (and subcpl (member found-specializer subcpl :test #'eq))))

           (setf found-specializer (ecase type
                                     (reader (car specializers))
                                     (writer (cadr specializers))))
           (setf found-specializer (ecase type
                                     (reader (car specializers))
                                     (writer (cadr specializers))))

@@ -1250,40 +1187,35 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (accessor-values-internal accessor-type accessor-class methods)))
 
 (defun accessor-values-internal (accessor-type accessor-class methods)
     (accessor-values-internal accessor-type accessor-class methods)))
 
 (defun accessor-values-internal (accessor-type accessor-class methods)

+  (unless accessor-class
+    (return-from accessor-values-internal (values nil nil)))

   (dolist (meth methods)
     (when (if (consp meth)
               (early-method-qualifiers meth)
   (dolist (meth methods)
     (when (if (consp meth)
               (early-method-qualifiers meth)

-              (method-qualifiers meth))
+              (safe-method-qualifiers meth))

       (return-from accessor-values-internal (values nil nil))))
   (let* ((meth (car methods))
       (return-from accessor-values-internal (values nil nil))))
   (let* ((meth (car methods))

-         (early-p (not (eq *boot-state* 'complete)))
-         (slot-name (when accessor-class
-                      (if (consp meth)
-                          (and (early-method-standard-accessor-p meth)
-                               (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)))
-                               (if early-p
-                                   (not (eq *the-class-standard-method*
-                                            (early-method-class meth)))
-                                   (standard-accessor-method-p meth))
-                               (if early-p
-                                   (early-accessor-method-slot-name meth)
-                                   (accessor-method-slot-name meth))))))
-         (slotd (and accessor-class
-                     (if early-p
-                         (dolist (slot (early-class-slotds accessor-class) nil)
-                           (when (eql slot-name
-                                      (early-slot-definition-name slot))
-                             (return slot)))
-                         (find-slot-definition accessor-class slot-name)))))
+         (early-p (not (eq **boot-state** 'complete)))
+         (slot-name
+          (cond
+            ((and (consp meth)
+                  (early-method-standard-accessor-p meth))
+             (early-method-standard-accessor-slot-name meth))
+            ((and (accessor-method-p meth)
+                  (member *the-class-standard-object*
+                          (if early-p
+                              (early-class-precedence-list accessor-class)
+                              (class-precedence-list accessor-class))))
+             (accessor-method-slot-name meth))
+            (t (return-from accessor-values-internal (values nil nil)))))
+         (slotd (if early-p
+                    (dolist (slot (early-class-slotds accessor-class) nil)
+                      (when (eql slot-name (early-slot-definition-name slot))
+                        (return slot)))
+                    (find-slot-definition accessor-class slot-name))))

     (when (and slotd
     (when (and slotd

-               (or early-p
-                   (slot-accessor-std-p slotd accessor-type)))
+               (or early-p (slot-accessor-std-p slotd accessor-type))
+               (or early-p (not (safe-p accessor-class))))

       (values (if early-p
                   (early-slot-definition-location slotd)
                   (slot-definition-location slotd))
       (values (if early-p
                   (early-slot-definition-location slotd)
                   (slot-definition-location slotd))

@@ -1296,7 +1228,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                      (generic-function-methods gf)))
         (all-index nil)
         (no-class-slots-p t)
                      (generic-function-methods gf)))
         (all-index nil)
         (no-class-slots-p t)

-        (early-p (not (eq *boot-state* 'complete)))
+        (early-p (not (eq **boot-state** 'complete)))

         first second (size 0))
     (declare (fixnum size))
     ;; class -> {(specl slotd)}
         first second (size 0))
     (declare (fixnum size))
     ;; class -> {(specl slotd)}

@@ -1309,29 +1241,32 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                       (writer (cadr specializers))))
              (specl-cpl (if early-p
                             (early-class-precedence-list specl)
                       (writer (cadr specializers))))
              (specl-cpl (if early-p
                             (early-class-precedence-list specl)

-                            (and (class-finalized-p specl)
-                                 (class-precedence-list specl))))
-             (so-p (member *the-class-std-object* specl-cpl))
+                            (when (class-finalized-p specl)
+                              (class-precedence-list specl))))
+             (so-p (member *the-class-standard-object* specl-cpl :test #'eq))

              (slot-name (if (consp method)
                             (and (early-method-standard-accessor-p method)
                                  (early-method-standard-accessor-slot-name
                                   method))
                             (accessor-method-slot-name method))))
         (when (or (null specl-cpl)
              (slot-name (if (consp method)
                             (and (early-method-standard-accessor-p 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))
+                  (null so-p)
+                  (member *the-class-structure-object* specl-cpl :test #'eq))

           (return-from make-accessor-table nil))
           (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)))
+        ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
+        ;; all of its subclasses. If either SPECL or one of the subclasses
+        ;; is not a standard-class, bail out.
+        (labels ((aux (class)
+                   (let ((slotd (find-slot-definition class slot-name)))
+                     (when slotd
+                       (unless (or early-p (slot-accessor-std-p slotd type))

                          (return-from make-accessor-table nil))
                          (return-from make-accessor-table nil))

-                       (push (cons specl slotd) (gethash class table)))))
-                 (gethash slot-name *name->class->slotd-table*))))
+                       (push (cons specl slotd) (gethash class table))))
+                   (dolist (subclass (sb-pcl::class-direct-subclasses class))
+                     (unless (class-finalized-p subclass)
+                       (return-from make-accessor-table nil))
+                     (aux subclass))))
+          (aux specl))))

     (maphash (lambda (class specl+slotd-list)
                (dolist (sclass (if early-p
                                    (early-class-precedence-list class)
     (maphash (lambda (class specl+slotd-list)
                (dolist (sclass (if early-p
                                    (early-class-precedence-list class)

@@ -1360,10 +1295,10 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (let ((definite-p t) (possibly-applicable-methods nil))
     (dolist (method (if (early-gf-p generic-function)
                         (early-gf-methods generic-function)
   (let ((definite-p t) (possibly-applicable-methods nil))
     (dolist (method (if (early-gf-p generic-function)
                         (early-gf-methods generic-function)

-                        (generic-function-methods generic-function)))
+                        (safe-generic-function-methods generic-function)))

       (let ((specls (if (consp method)
                         (early-method-specializers method t)
       (let ((specls (if (consp method)
                         (early-method-specializers method t)

-                        (method-specializers method)))
+                        (safe-method-specializers method)))

             (types types)
             (possibly-applicable-p t) (applicable-p t))
         (dolist (specl specls)
             (types types)
             (possibly-applicable-p t) (applicable-p t))
         (dolist (specl specls)

@@ -1377,22 +1312,21 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
         (when possibly-applicable-p
           (unless applicable-p (setq definite-p nil))
           (push method possibly-applicable-methods))))
         (when possibly-applicable-p
           (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)))))
-      (values (sort-applicable-methods precedence
-                                       (nreverse possibly-applicable-methods)
-                                       types)
-              definite-p))))
+    (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+        (get-generic-fun-info generic-function)
+      (declare (ignore nreq applyp metatypes nkeys))
+      (let* ((precedence (arg-info-precedence arg-info)))
+        (values (sort-applicable-methods precedence
+                                         (nreverse possibly-applicable-methods)
+                                         types)
+                definite-p)))))

 
 (defun sort-applicable-methods (precedence methods types)
   (sort-methods methods
                 precedence
                 (lambda (class1 class2 index)
                   (let* ((class (type-class (nth index types)))
 
 (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)
+                         (cpl (if (eq **boot-state** 'complete)

                                   (class-precedence-list class)
                                   (early-class-precedence-list class))))
                     (if (memq class2 (memq class1 cpl))
                                   (class-precedence-list class)
                                   (early-class-precedence-list class))))
                     (if (memq class2 (memq class1 cpl))

@@ -1416,12 +1350,12 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (stable-sort methods #'sorter)))
 
 (defun order-specializers (specl1 specl2 index compare-classes-function)
     (stable-sort methods #'sorter)))
 
 (defun order-specializers (specl1 specl2 index compare-classes-function)

-  (let ((type1 (if (eq *boot-state* 'complete)
+  (let ((type1 (if (eq **boot-state** 'complete)

                    (specializer-type specl1)
                    (specializer-type specl1)

-                   (!bootstrap-get-slot 'specializer specl1 'type)))
-        (type2 (if (eq *boot-state* 'complete)
+                   (!bootstrap-get-slot 'specializer specl1 '%type)))
+        (type2 (if (eq **boot-state** 'complete)

                    (specializer-type specl2)
                    (specializer-type specl2)

-                   (!bootstrap-get-slot 'specializer specl2 'type))))
+                   (!bootstrap-get-slot 'specializer specl2 '%type))))

     (cond ((eq specl1 specl2)
            nil)
           ((atom type1)
     (cond ((eq specl1 specl2)
            nil)
           ((atom type1)

@@ -1440,9 +1374,17 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                          (t specl2)))
              (class-eq (case (car type2)
                          (eql specl2)
                          (t specl2)))
              (class-eq (case (car type2)
                          (eql specl2)

+                         ;; FIXME: This says that all CLASS-EQ
+                         ;; specializers are equally specific, which
+                         ;; is fair enough because only one CLASS-EQ
+                         ;; specializer can ever be appliable.  If
+                         ;; ORDER-SPECIALIZERS should only ever be
+                         ;; called on specializers from applicable
+                         ;; methods, we could replace this with a BUG.

                          (class-eq nil)
                          (class type1)))
              (eql      (case (car type2)
                          (class-eq nil)
                          (class type1)))
              (eql      (case (car type2)

+                         ;; similarly.

                          (eql nil)
                          (t specl1))))))))
 
                          (eql nil)
                          (t specl1))))))))
 

@@ -1489,9 +1431,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 ;;; CMUCL comment: used only in map-all-orders
 (defun class-might-precede-p (class1 class2)
 
 ;;; 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))))
-      (class-can-precede-p class1 class2)))
+  (not (member class1 (cdr (class-precedence-list class2)) :test #'eq)))

 
 (defun compute-precedence (lambda-list nreq argument-precedence-order)
   (if (null argument-precedence-order)
 
 (defun compute-precedence (lambda-list nreq argument-precedence-order)
   (if (null argument-precedence-order)

@@ -1501,22 +1441,32 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
               argument-precedence-order)))
 
 (defun cpl-or-nil (class)
               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))
+  (if (eq **boot-state** 'complete)
+      (progn
+        ;; 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)
+          (return-from cpl-or-nil (class-precedence-list class)))
+
+        ;; if we can finalize an unfinalized class, then do so
+        (when (and (not (class-finalized-p class))
+                   (not (class-has-a-forward-referenced-superclass-p class))
+                   (not (class-has-a-cpl-protocol-violation-p class)))
+          (finalize-inheritance class)
+          (class-precedence-list class)))
+

       (early-class-precedence-list class)))
 
 (defun saut-and (specl type)
       (early-class-precedence-list class)))
 
 (defun saut-and (specl type)

@@ -1569,7 +1519,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (let ((pred (memq specl (cpl-or-nil type))))
     (values pred
             (or pred
   (let ((pred (memq specl (cpl-or-nil type))))
     (values pred
             (or pred

-                (if (not *in-precompute-effective-methods-p*)
+                (if (not *in-*subtypep*)

                     ;; classes might get common subclass
                     (superclasses-compatible-p specl type)
                     ;; worry only about existing classes
                     ;; classes might get common subclass
                     (superclasses-compatible-p specl type)
                     ;; worry only about existing classes

@@ -1633,24 +1583,38 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                            'specializer-applicable-using-type-p
                            type)))))
 
                            'specializer-applicable-using-type-p
                            type)))))
 

-(defun map-all-classes (function &optional (root t))
-  (let ((braid-p (or (eq *boot-state* 'braid)
-                     (eq *boot-state* 'complete))))
+(defun map-all-classes (fun &optional (root t))
+  (let ((all-classes (make-hash-table :test 'eq))
+        (braid-p (or (eq **boot-state** 'braid)
+                     (eq **boot-state** 'complete))))

     (labels ((do-class (class)
     (labels ((do-class (class)

-               (mapc #'do-class
-                     (if braid-p
-                         (class-direct-subclasses class)
-                         (early-class-direct-subclasses class)))
-               (funcall function class)))
+               (unless (gethash class all-classes)
+                 (setf (gethash class all-classes) t)
+                 (funcall fun class)
+                 (mapc #'do-class
+                       (if braid-p
+                           (class-direct-subclasses class)
+                           (early-class-direct-subclasses class))))))

       (do-class (if (symbolp root)
                     (find-class root)
       (do-class (if (symbolp root)
                     (find-class root)

-                    root)))))
+                    root)))
+    nil))

 \f
 \f

+;;; Not synchronized, as all the uses we have for it are multiple ones
+;;; and need WITH-LOCKED-SYSTEM-TABLE in any case.
+;;;
+;;; FIXME: Is it really more efficient to store this stuff in a global
+;;; table instead of having a slot in each method?
+;;;
+;;; FIXME: This table also seems to contain early methods, which should
+;;; presumably be dropped during the bootstrap.

 (defvar *effective-method-cache* (make-hash-table :test 'eq))
 
 (defun flush-effective-method-cache (generic-function)
 (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*)))
+  (let ((cache *effective-method-cache*))
+    (with-locked-system-table (cache)
+      (dolist (method (generic-function-methods generic-function))
+        (remhash method cache)))))

 
 (defun get-secondary-dispatch-function (gf methods types
                                         &optional method-alist wrappers)
 
 (defun get-secondary-dispatch-function (gf methods types
                                         &optional method-alist wrappers)

@@ -1666,20 +1630,16 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                             all-applicable-p
                                             (all-sorted-p t)
                                             function-p)
                                             all-applicable-p
                                             (all-sorted-p t)
                                             function-p)

-  (if (null methods)
-      (if function-p
-          (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))
-            (lambda (&rest args)
-              (apply #'no-applicable-method gf args))))
+   (if (null methods)
+      (lambda (method-alist wrappers)
+        (declare (ignore method-alist wrappers))
+        (lambda (&rest args)
+          (call-no-applicable-method gf args)))

       (let* ((key (car methods))
       (let* ((key (car methods))

-             (ht-value (or (gethash key *effective-method-cache*)
-                           (setf (gethash key *effective-method-cache*)
-                                 (cons nil nil)))))
+             (ht *effective-method-cache*)
+             (ht-value (with-locked-system-table (ht)
+                         (or (gethash key ht)
+                             (setf (gethash key ht) (cons nil nil))))))

         (if (and (null (cdr methods)) all-applicable-p ; the most common case
                  (null method-alist-p) wrappers-p (not function-p))
             (or (car ht-value)
         (if (and (null (cdr methods)) all-applicable-p ; the most common case
                  (null method-alist-p) wrappers-p (not function-p))
             (or (car ht-value)

@@ -1701,7 +1661,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                                             wrappers-p all-applicable-p
                                             all-sorted-p function-p)
   (if (and all-applicable-p all-sorted-p (not function-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)
+      (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
           (let* ((combin (generic-function-method-combination gf))
                  (effective (compute-effective-method gf combin methods)))
             (make-effective-method-function1 gf effective method-alist-p

@@ -1724,24 +1684,53 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
   (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
 
 (defun methods-contain-eql-specializer-p (methods)
   (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
 
 (defun methods-contain-eql-specializer-p (methods)

-  (and (eq *boot-state* 'complete)
+  (and (eq **boot-state** 'complete)

        (dolist (method methods nil)
          (when (dolist (spec (method-specializers method) nil)
                  (when (eql-specializer-p spec) (return t)))
            (return t)))))
 \f
 (defun update-dfun (generic-function &optional dfun cache info)
        (dolist (method methods nil)
          (when (dolist (spec (method-specializers method) nil)
                  (when (eql-specializer-p spec) (return t)))
            (return t)))))
 \f
 (defun update-dfun (generic-function &optional dfun cache info)

-  (let* ((early-p (early-gf-p generic-function))
-         (gf-name (if early-p
-                      (!early-gf-name 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))))
-      (set-funcallable-instance-function generic-function dfun)
-      (set-fun-name generic-function gf-name)
-      dfun)))
+  (let ((early-p (early-gf-p generic-function)))
+    (flet ((update ()
+             ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can
+             ;; access it, and so that it's there for eg. future cache updates.
+             (set-dfun generic-function dfun cache info)
+             (let ((dfun (if early-p
+                             (or dfun (make-initial-dfun generic-function))
+                             (compute-discriminating-function generic-function))))
+               (set-funcallable-instance-function generic-function dfun)
+               (let ((gf-name (if early-p
+                                  (!early-gf-name generic-function)
+                                  (generic-function-name generic-function))))
+                 (set-fun-name generic-function gf-name)
+                 dfun))))
+      ;; This needs to be atomic per generic function, consider:
+      ;;   1. T1 sets dfun-state to S1 and computes discr. fun using S1
+      ;;   2. T2 sets dfun-state to S2 and computes discr. fun using S2
+      ;;   3. T2 sets fin
+      ;;   4. T1 sets fin
+      ;; Oops: now dfun-state and fin don't match! Since just calling
+      ;; a generic can cause the dispatch function to be updated we
+      ;; need a lock here.
+      ;;
+      ;; We need to accept recursion, because PCL is nasty and twisty,
+      ;; and we need to disable interrupts because it would be bad if
+      ;; we updated the DFUN-STATE but not the dispatch function.
+      ;;
+      ;; This is sufficient, because all the other calls to SET-DFUN
+      ;; are part of this same code path (done while the lock is held),
+      ;; which we AVER.
+      ;;
+      ;; KLUDGE: No need to lock during bootstrap.
+      (if early-p
+          (update)
+          (let ((lock (gf-lock generic-function)))
+            ;; FIXME: GF-LOCK is a generic function... Are there cases
+            ;; where we can end up in a metacircular loop here? In
+            ;; case there are, better fetch it while interrupts are
+            ;; still enabled...
+            (sb-thread::call-with-recursive-system-lock #'update lock))))))

 \f
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)
 \f
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)

@@ -1751,7 +1740,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; 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
 ;;; 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*)))
 (defun list-dfun (gf)
   (let* ((sym (type-of (gf-dfun-info gf)))
          (a (assq sym *dfun-list*)))

@@ -1814,7 +1803,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           (format t "~%   ~S~%" (caddr type+count+sizes)))
         *dfun-count*)
   (values))
           (format t "~%   ~S~%" (caddr type+count+sizes)))
         *dfun-count*)
   (values))

-|#
+||#

 
 (defun gfs-of-type (type)
   (unless (consp type) (setq type (list type)))
 
 (defun gfs-of-type (type)
   (unless (consp type) (setq type (list type)))