0.9.18.38:
[sbcl.git] / src / pcl / boot.lisp
index ca6d811..66d26ef 100644 (file)
@@ -413,7 +413,7 @@ bootstrapping.
                     specializers)
              (consp initargs-form)
              (eq (car initargs-form) 'list*)
-             (memq (cadr initargs-form) '(:function :fast-function))
+             (memq (cadr initargs-form) '(:function))
              (consp (setq fn (caddr initargs-form)))
              (eq (car fn) 'function)
              (consp (setq fn-lambda (cadr fn)))
@@ -652,6 +652,11 @@ bootstrapping.
               ((:forthcoming-defclass-type)
                '(ignorable))))))))
 
+;;; For passing a list (groveled by the walker) of the required
+;;; parameters whose bindings are modified in the method body to the
+;;; optimized-slot-value* macros.
+(define-symbol-macro %parameter-binding-modified ())
+
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
     (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
@@ -741,7 +746,8 @@ bootstrapping.
                                 (return nil))))))
           (multiple-value-bind
                 (walked-lambda call-next-method-p closurep
-                               next-method-p-p setq-p)
+                               next-method-p-p setq-p
+                               parameters-setqd)
               (walk-method-lambda method-lambda
                                   required-parameters
                                   env
@@ -752,17 +758,15 @@ bootstrapping.
                                   walked-documentation)
                 (parse-body (cddr walked-lambda))
               (declare (ignore walked-documentation))
-              (when (or next-method-p-p call-next-method-p)
-                (setq plist (list* :needs-next-methods-p t plist)))
               (when (some #'cdr slots)
                 (multiple-value-bind (slot-name-lists call-list)
                     (slot-name-lists-from-slots slots calls)
                   (setq plist
                         `(,@(when slot-name-lists
                                   `(:slot-name-lists ,slot-name-lists))
-                          ,@(when call-list
-                                  `(:call-list ,call-list))
-                          ,@plist))
+                            ,@(when call-list
+                                    `(:call-list ,call-list))
+                            ,@plist))
                   (setq walked-lambda-body
                         `((pv-binding (,required-parameters
                                        ,slot-name-lists
@@ -770,7 +774,7 @@ bootstrapping.
                                         (intern-pv-table
                                          :slot-name-lists ',slot-name-lists
                                          :call-list ',call-list)))
-                           ,@walked-lambda-body)))))
+                            ,@walked-lambda-body)))))
               (when (and (memq '&key lambda-list)
                          (not (memq '&allow-other-keys lambda-list)))
                 (let ((aux (memq '&aux lambda-list)))
@@ -795,9 +799,16 @@ bootstrapping.
                                            :closurep ,closurep
                                            :applyp ,applyp)
                            ,@walked-declarations
-                           ,@walked-lambda-body))
+                           (locally
+                               (declare (disable-package-locks
+                                         %parameter-binding-modified))
+                             (symbol-macrolet ((%parameter-binding-modified
+                                                ',@parameters-setqd))
+                               (declare (enable-package-locks
+                                         %parameter-binding-modified))
+                               ,@walked-lambda-body))))
                       `(,@(when plist
-                                `(:plist ,plist))
+                                `(plist ,plist))
                           ,@(when documentation
                                   `(:documentation ,documentation)))))))))))
 
@@ -876,6 +887,8 @@ bootstrapping.
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
+(defstruct (constant-method-call (:copier nil) (:include method-call))
+  value)
 
 #-sb-fluid (declaim (sb-ext:freeze-type method-call))
 
@@ -899,6 +912,9 @@ bootstrapping.
   pv-cell
   next-method-call
   arg-info)
+(defstruct (constant-fast-method-call
+             (:copier nil) (:include fast-method-call))
+  value)
 
 #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
 
@@ -964,58 +980,70 @@ bootstrapping.
      (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
      (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
 
-(defmacro invoke-effective-method-function (emf restp
-                                                &rest required-args+rest-arg)
-  (unless (constantp restp)
-    (error "The RESTP argument is not constant."))
-  ;; FIXME: The RESTP handling here is confusing and maybe slightly
-  ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
-  ;;   (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
-  ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
-  (setq restp (constant-form-value restp))
-  `(progn
-     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
-     (cond ((typep ,emf 'fast-method-call)
-            (invoke-fast-method-call ,emf ,@required-args+rest-arg))
-           ;; "What," you may wonder, "do these next two clauses do?"
-           ;; In that case, you are not a PCL implementor, for they
-           ;; considered this to be self-documenting.:-| Or CSR, for
-           ;; that matter, since he can also figure it out by looking
-           ;; at it without breaking stride. For the rest of us,
-           ;; though: From what the code is doing with .SLOTS. and
-           ;; whatnot, evidently it's implementing SLOT-VALUEish and
-           ;; GET-SLOT-VALUEish things. Then we can reason backwards
-           ;; and conclude that setting EMF to a FIXNUM is an
-           ;; optimized way to represent these slot access operations.
-           ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
-               `(((typep ,emf 'fixnum)
-                  (let* ((.slots. (get-slots-or-nil
-                                   ,(car required-args+rest-arg)))
-                         (value (when .slots. (clos-slots-ref .slots. ,emf))))
-                    (if (eq value +slot-unbound+)
-                        (slot-unbound-internal ,(car required-args+rest-arg)
-                                               ,emf)
-                        value)))))
-           ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
-               `(((typep ,emf 'fixnum)
-                  (let ((.new-value. ,(car required-args+rest-arg))
-                        (.slots. (get-slots-or-nil
-                                  ,(cadr required-args+rest-arg))))
-                    (when .slots.
-                      (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
-           ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
-           ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
-           ;; there was no explanation and presumably the code is 10+
-           ;; years stale, I simply deleted it. -- WHN)
-           (t
-            (etypecase ,emf
-              (method-call
-               (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
-              (function
-               ,(if restp
-                    `(apply (the function ,emf) ,@required-args+rest-arg)
-                    `(funcall (the function ,emf)
-                              ,@required-args+rest-arg))))))))
+(defun effective-method-optimized-slot-access-clause
+    (emf restp required-args+rest-arg)
+  ;; "What," you may wonder, "do these next two clauses do?" In that
+  ;; case, you are not a PCL implementor, for they considered this to
+  ;; be self-documenting.:-| Or CSR, for that matter, since he can
+  ;; also figure it out by looking at it without breaking stride. For
+  ;; the rest of us, though: From what the code is doing with .SLOTS.
+  ;; and whatnot, evidently it's implementing SLOT-VALUEish and
+  ;; GET-SLOT-VALUEish things. Then we can reason backwards and
+  ;; conclude that setting EMF to a FIXNUM is an optimized way to
+  ;; represent these slot access operations.
+  (when (not restp)
+    (let ((length (length required-args+rest-arg)))
+      (cond ((= 1 length)
+             `((fixnum
+                (let* ((.slots. (get-slots-or-nil
+                                 ,(car required-args+rest-arg)))
+                       (value (when .slots. (clos-slots-ref .slots. ,emf))))
+                  (if (eq value +slot-unbound+)
+                      (slot-unbound-internal ,(car required-args+rest-arg)
+                                             ,emf)
+                      value)))))
+            ((= 2 length)
+             `((fixnum
+                (let ((.new-value. ,(car required-args+rest-arg))
+                      (.slots. (get-slots-or-nil
+                                ,(cadr required-args+rest-arg))))
+                  (when .slots.
+                    (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
+      ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+      ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+      ;; there was no explanation and presumably the code is 10+
+      ;; years stale, I simply deleted it. -- WHN)
+      )))
+
+;;; Before SBCL 0.9.16.7 instead of
+;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
+;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
+;;; to make less work for the compiler we take a path that doesn't
+;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all.
+(macrolet ((def (name &optional narrow)
+             `(defmacro ,name (emf restp &rest required-args+rest-arg)
+                (unless (constantp restp)
+                  (error "The RESTP argument is not constant."))
+                (setq restp (constant-form-value restp))
+                (with-unique-names (emf-n)
+                  `(locally
+                       (declare (optimize (sb-c:insert-step-conditions 0)))
+                     (let ((,emf-n ,emf))
+                       (trace-emf-call ,emf-n ,restp (list ,@required-args+rest-arg))
+                       (etypecase ,emf-n
+                         (fast-method-call
+                          (invoke-fast-method-call ,emf-n ,@required-args+rest-arg))
+                         ,@,(unless narrow
+                              `(effective-method-optimized-slot-access-clause
+                                emf-n restp required-args+rest-arg))
+                         (method-call
+                          (invoke-method-call ,emf-n ,restp ,@required-args+rest-arg))
+                         (function
+                          ,(if restp
+                               `(apply ,emf-n ,@required-args+rest-arg)
+                            `(funcall ,emf-n ,@required-args+rest-arg))))))))))
+  (def invoke-effective-method-function nil)
+  (def invoke-narrow-effective-method-function t))
 
 (defun invoke-emf (emf args)
   (trace-emf-call emf t args)
@@ -1087,35 +1115,12 @@ bootstrapping.
      (apply emf args))))
 \f
 
-(defmacro fast-narrowed-emf (emf)
-  ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to dispatch on
-  ;; the possibility that EMF might be of type FIXNUM (as an optimized
-  ;; representation of a slot accessor). But as far as I (WHN
-  ;; 2002-06-11) can tell, it's impossible for such a representation
-  ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that
-  ;; when called from this context it needn't worry about the FIXNUM
-  ;; case, we can keep those cases from being compiled, which is good
-  ;; both because it saves bytes and because it avoids annoying type
-  ;; mismatch compiler warnings.
-  ;;
-  ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type system isn't smart
-  ;; enough about NOT and intersection types to benefit from a (NOT
-  ;; FIXNUM) declaration here. -- WHN 2002-06-12 (FIXME: maybe it is
-  ;; now... -- CSR, 2003-06-07)
-  ;;
-  ;; FIXME: Might the FUNCTION type be omittable here, leaving only
-  ;; METHOD-CALLs? Failing that, could this be documented somehow?
-  ;; (It'd be nice if the types involved could be understood without
-  ;; solving the halting problem.)
-  `(the (or function method-call fast-method-call)
-     ,emf))
-
 (defmacro fast-call-next-method-body ((args next-method-call rest-arg)
                                       method-name-declaration
                                       cnm-args)
   `(if ,next-method-call
-       ,(let ((call `(invoke-effective-method-function
-                      (fast-narrowed-emf ,next-method-call)
+       ,(let ((call `(invoke-narrow-effective-method-function
+                      ,next-method-call
                       ,(not (null rest-arg))
                       ,@args
                       ,@(when rest-arg `(,rest-arg)))))
@@ -1149,7 +1154,8 @@ bootstrapping.
              ,@body)
         `(flet (,@(when call-next-method-p
                         `((call-next-method (&rest cnm-args)
-                           (declare (muffle-conditions code-deletion-note))
+                            (declare (muffle-conditions code-deletion-note)
+                                     (optimize (sb-c:insert-step-conditions 0)))
                            ,@(if (safe-code-p env)
                                  `((%check-cnm-args cnm-args (list ,@args)
                                                     ',method-name-declaration))
@@ -1160,8 +1166,8 @@ bootstrapping.
                                                         ,method-name-declaration
                                                        cnm-args))))
                 ,@(when next-method-p-p
-                        `((next-method-p
-                           ()
+                        `((next-method-p ()
+                           (declare (optimize (sb-c:insert-step-conditions 0)))
                            (not (null ,next-method-call))))))
            (let ,rebindings
              ,@(when rebindings `((declare (ignorable ,@all-params))))
@@ -1280,13 +1286,18 @@ bootstrapping.
           return tail))
 
 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
-  (let ((call-next-method-p nil)   ; flag indicating that CALL-NEXT-METHOD
-                                   ; should be in the method definition
-        (closurep nil)             ; flag indicating that #'CALL-NEXT-METHOD
-                                   ; was seen in the body of a method
-        (next-method-p-p nil)      ; flag indicating that NEXT-METHOD-P
-                                   ; should be in the method definition
-        (setq-p nil))
+  (let (;; flag indicating that CALL-NEXT-METHOD should be in the
+        ;; method definition
+        (call-next-method-p nil)
+        ;; flag indicating that #'CALL-NEXT-METHOD was seen in the
+        ;; body of a method
+        (closurep nil)
+        ;; flag indicating that NEXT-METHOD-P should be in the method
+        ;; definition
+        (next-method-p-p nil)
+        ;; a list of all required parameters whose bindings might be
+        ;; modified in the method body.
+        (parameters-setqd nil))
     (flet ((walk-function (form context env)
              (cond ((not (eq context :eval)) form)
                    ;; FIXME: Jumping to a conclusion from the way it's used
@@ -1310,7 +1321,34 @@ bootstrapping.
                     ;; force method doesn't really cost much; a little
                     ;; loss of discrimination over IGNORED variables
                     ;; should be all.  -- CSR, 2004-07-01
-                    (setq setq-p t)
+                    ;;
+                    ;; As of 2006-09-18 modified parameter bindings
+                    ;; are now tracked with more granularity than just
+                    ;; one SETQ-P flag, in order to disable SLOT-VALUE
+                    ;; optimizations for parameters that are SETQd.
+                    ;; The old binary SETQ-P flag is still used for
+                    ;; all other purposes, since as noted above, the
+                    ;; extra cost is minimal. -- JES, 2006-09-18
+                    ;;
+                    ;; The walker will split (SETQ A 1 B 2) to
+                    ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
+                    ;; only need to handle the simple case of SETQ
+                    ;; here.
+                    (let ((vars (if (eq (car form) 'setq)
+                                    (list (second form))
+                                    (second form))))
+                      (dolist (var vars)
+                        ;; Note that we don't need to check for
+                        ;; %VARIABLE-REBINDING declarations like is
+                        ;; done in CAN-OPTIMIZE-ACCESS1, since the
+                        ;; bindings that will have that declation will
+                        ;; never be SETQd.
+                        (when (var-declaration '%class var env)
+                          ;; If a parameter binding is shadowed by
+                          ;; another binding it won't have a %CLASS
+                          ;; declaration anymore, and this won't get
+                          ;; executed.
+                          (pushnew var parameters-setqd))))
                     form)
                    ((and (eq (car form) 'function)
                          (cond ((eq (cadr form) 'call-next-method)
@@ -1325,23 +1363,14 @@ bootstrapping.
                    ((and (memq (car form)
                                '(slot-value set-slot-value slot-boundp))
                          (constantp (caddr form)))
-                     (let ((parameter (can-optimize-access form
-                                                           required-parameters
-                                                           env)))
+                    (let ((parameter (can-optimize-access form
+                                                          required-parameters
+                                                          env)))
                       (let ((fun (ecase (car form)
                                    (slot-value #'optimize-slot-value)
                                    (set-slot-value #'optimize-set-slot-value)
                                    (slot-boundp #'optimize-slot-boundp))))
                         (funcall fun slots parameter form))))
-                   ((and (eq (car form) 'apply)
-                         (consp (cadr form))
-                         (eq (car (cadr form)) 'function)
-                         (generic-function-name-p (cadr (cadr form))))
-                    (optimize-generic-function-call
-                     form required-parameters env slots calls))
-                   ((generic-function-name-p (car form))
-                    (optimize-generic-function-call
-                     form required-parameters env slots calls))
                    (t form))))
 
       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
@@ -1349,7 +1378,8 @@ bootstrapping.
                 call-next-method-p
                 closurep
                 next-method-p-p
-                setq-p)))))
+                (not (null parameters-setqd))
+                parameters-setqd)))))
 
 (defun generic-function-name-p (name)
   (and (legal-fun-name-p name)
@@ -1358,41 +1388,25 @@ bootstrapping.
            (standard-generic-function-p (gdefinition name))
            (funcallable-instance-p (gdefinition name)))))
 \f
-(defvar *method-function-plist* (make-hash-table :test 'eq))
-
-(defun method-function-plist (method-function)
-  (gethash method-function *method-function-plist*))
-
-(defun (setf method-function-plist) (val method-function)
-  (setf (gethash method-function *method-function-plist*) val))
-
-(defun method-function-get (method-function key &optional default)
-  (getf (method-function-plist method-function) key default))
-
-(defun (setf method-function-get)
-    (val method-function key)
-  (setf (getf (method-function-plist method-function) key) val))
-
-(defun method-function-pv-table (method-function)
-  (method-function-get method-function :pv-table))
-
-(defun method-function-method (method-function)
-  (method-function-get method-function :method))
-
-(defun method-function-needs-next-methods-p (method-function)
-  (method-function-get method-function :needs-next-methods-p t))
+(defun method-plist-value (method key &optional default)
+  (let ((plist (if (consp method)
+                   (getf (early-method-initargs method) 'plist)
+                   (object-plist method))))
+    (getf plist key default)))
+
+(defun (setf method-plist-value) (new-value method key &optional default)
+  (if (consp method)
+      (setf (getf (getf (early-method-initargs method) 'plist) key default)
+            new-value)
+      (setf (getf (object-plist method) key default) new-value)))
 \f
-(defmacro method-function-closure-generator (method-function)
-  `(method-function-get ,method-function 'closure-generator))
-
 (defun load-defmethod
     (class name quals specls ll initargs source-location)
   (setq initargs (copy-tree initargs))
-  (let ((method-spec (or (getf initargs :method-spec)
-                         (make-method-spec name quals specls))))
-    (setf (getf initargs :method-spec) method-spec)
-    (load-defmethod-internal class name quals specls
-                             ll initargs source-location)))
+  (setf (getf (getf initargs 'plist) :name)
+        (make-method-spec name quals specls))
+  (load-defmethod-internal class name quals specls
+                           ll initargs source-location))
 
 (defun load-defmethod-internal
     (method-class gf-spec qualifiers specializers lambda-list
@@ -1429,38 +1443,25 @@ bootstrapping.
 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
   `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
 
-(defun initialize-method-function (initargs &optional return-function-p method)
+(defun initialize-method-function (initargs method)
   (let* ((mf (getf initargs :function))
-         (method-spec (getf initargs :method-spec))
-         (plist (getf initargs :plist))
-         (pv-table nil)
-         (mff (getf initargs :fast-function)))
-    (flet ((set-mf-property (p v)
-             (when mf
-               (setf (method-function-get mf p) v))
-             (when mff
-               (setf (method-function-get mff p) v))))
-      (when method-spec
-        (when mf
-          (setq mf (set-fun-name mf method-spec)))
-        (when mff
-          (let ((name `(fast-method ,@(cdr method-spec))))
-            (set-fun-name mff name)
-            (unless mf
-              (set-mf-property :name name)))))
-      (when plist
+         (mff (and (typep mf '%method-function)
+                   (%method-function-fast-function mf)))
+         (plist (getf initargs 'plist))
+         (name (getf plist :name)))
+    (when name
+      (when mf
+        (setq mf (set-fun-name mf name)))
+      (when (and mff (consp name) (eq (car name) 'slow-method))
+        (let ((fast-name `(fast-method ,@(cdr name))))
+          (set-fun-name mff fast-name))))
+    (when plist
+      (let ((plist plist))
         (let ((snl (getf plist :slot-name-lists))
               (cl (getf plist :call-list)))
           (when (or snl cl)
-            (setq pv-table (intern-pv-table :slot-name-lists snl
-                                            :call-list cl))
-            (set-mf-property :pv-table pv-table)))
-        (loop (when (null plist) (return nil))
-              (set-mf-property (pop plist) (pop plist)))
-        (when method
-          (set-mf-property :method method))
-        (when return-function-p
-          (or mf (method-function-from-fast-function mff)))))))
+            (setf (method-plist-value method :pv-table)
+                  (intern-pv-table :slot-name-lists snl :call-list cl))))))))
 \f
 (defun analyze-lambda-list (lambda-list)
   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
@@ -1738,10 +1739,10 @@ bootstrapping.
 
 (defvar *sm-specializers-index*
   (!bootstrap-slot-index 'standard-method 'specializers))
-(defvar *sm-fast-function-index*
-  (!bootstrap-slot-index 'standard-method 'fast-function))
 (defvar *sm-%function-index*
   (!bootstrap-slot-index 'standard-method '%function))
+(defvar *sm-qualifiers-index*
+  (!bootstrap-slot-index 'standard-method 'qualifiers))
 (defvar *sm-plist-index*
   (!bootstrap-slot-index 'standard-method 'plist))
 
@@ -1749,7 +1750,7 @@ bootstrapping.
 ;;; class and deal with it as appropriate.  In fact we probably don't
 ;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
 ;;; the standard reader method for METHOD-SPECIALIZERS.  Probably.
-(dolist (s '(specializers fast-function %function plist))
+(dolist (s '(specializers %function plist))
   (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
            (!bootstrap-slot-index 'standard-reader-method s)
            (!bootstrap-slot-index 'standard-writer-method s)
@@ -1766,15 +1767,9 @@ bootstrapping.
         (clos-slots-ref (get-slots method) *sm-specializers-index*)
         (method-specializers method))))
 (defun safe-method-fast-function (method)
-  (let ((standard-method-classes
-         (list *the-class-standard-method*
-               *the-class-standard-reader-method*
-               *the-class-standard-writer-method*
-               *the-class-standard-boundp-method*))
-        (class (class-of method)))
-    (if (member class standard-method-classes)
-        (clos-slots-ref (get-slots method) *sm-fast-function-index*)
-        (method-fast-function method))))
+  (let ((mf (safe-method-function method)))
+    (and (typep mf '%method-function)
+         (%method-function-fast-function mf))))
 (defun safe-method-function (method)
   (let ((standard-method-classes
          (list *the-class-standard-method*
@@ -1793,8 +1788,7 @@ bootstrapping.
                *the-class-standard-boundp-method*))
         (class (class-of method)))
     (if (member class standard-method-classes)
-        (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*)))
-          (getf plist 'qualifiers))
+        (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
         (method-qualifiers method))))
 
 (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
@@ -2046,11 +2040,12 @@ bootstrapping.
         fun-name
         &rest all-keys
         &key environment (lambda-list nil lambda-list-p)
-             (generic-function-class 'standard-generic-function gf-class-p)
+        (generic-function-class 'standard-generic-function)
         &allow-other-keys)
   (real-ensure-gf-internal generic-function-class all-keys environment)
-  (unless (or (null gf-class-p)
-              (eq (class-of existing) generic-function-class))
+  ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS,
+  ;; which is what makes the next line work
+  (unless (eq (class-of existing) generic-function-class)
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)
@@ -2107,7 +2102,6 @@ bootstrapping.
 
 (defun early-make-a-method (class qualifiers arglist specializers initargs doc
                             &key slot-name object-class method-class-function)
-  (initialize-method-function initargs)
   (let ((parsed ())
         (unparsed ()))
     ;; Figure out whether we got class objects or class names as the
@@ -2125,27 +2119,32 @@ bootstrapping.
                                specializers))
         (setq unparsed specializers
               parsed ()))
-    (list :early-method           ;This is an early method dammit!
-
-          (getf initargs :function)
-          (getf initargs :fast-function)
-
-          parsed                  ;The parsed specializers. This is used
-                                  ;by early-method-specializers to cache
-                                  ;the parse. Note that this only comes
-                                  ;into play when there is more than one
-                                  ;early method on an early gf.
-
-          (append
-           (list class        ;A list to which real-make-a-method
-                 qualifiers      ;can be applied to make a real method
-                 arglist    ;corresponding to this early one.
-                 unparsed
-                 initargs
-                 doc)
-           (when slot-name
-             (list :slot-name slot-name :object-class object-class
-                   :method-class-function method-class-function))))))
+    (let ((result
+           (list :early-method
+
+                 (getf initargs :function)
+                 (let ((mf (getf initargs :function)))
+                   (aver mf)
+                   (and (typep mf '%method-function)
+                        (%method-function-fast-function mf)))
+
+                 ;; the parsed specializers. This is used by
+                 ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
+                 ;; Note that this only comes into play when there is
+                 ;; more than one early method on an early gf.
+                 parsed
+
+                 ;; A list to which REAL-MAKE-A-METHOD can be applied
+                 ;; to make a real method corresponding to this early
+                 ;; one.
+                 (append
+                  (list class qualifiers arglist unparsed
+                        initargs doc)
+                  (when slot-name
+                    (list :slot-name slot-name :object-class object-class
+                          :method-class-function method-class-function))))))
+      (initialize-method-function initargs result)
+      result)))
 
 (defun real-make-a-method
        (class qualifiers lambda-list specializers initargs doc
@@ -2217,12 +2216,22 @@ bootstrapping.
 (defun early-method-lambda-list (early-method)
   (third (fifth early-method)))
 
+(defun early-method-initargs (early-method)
+  (fifth (fifth early-method)))
+
+(defun (setf early-method-initargs) (new-value early-method)
+  (setf (fifth (fifth early-method)) new-value))
+
 (defun early-add-named-method (generic-function-name
                                qualifiers
                                specializers
                                arglist
                                &rest initargs)
-  (let* ((gf (ensure-generic-function generic-function-name))
+  (let* (;; we don't need to deal with the :generic-function-class
+         ;; argument here because the default,
+         ;; STANDARD-GENERIC-FUNCTION, is right for all early generic
+         ;; functions.  (See REAL-ADD-NAMED-METHOD)
+         (gf (ensure-generic-function generic-function-name))
          (existing
            (dolist (m (early-gf-methods gf))
              (when (and (equal (early-method-specializers m) specializers)