X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=fa09faadb11b5b2b87ee219186629bdc2140cbab;hb=fe124f3fad91ea52851f20f9cd73823d71f39ad1;hp=4750fac21bebfeaaa7daeb40be856a01af09dba7;hpb=832f3b5652ae1b4a8888829cd4a1b391a8ca9952;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 4750fac..fa09faa 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -24,6 +24,18 @@
 ;;;; specification.
 
 (in-package "SB-PCL")
+
+;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation
+;;;; for optimizing GF calls inside method bodies using a PV approach,
+;;;; inherited from the original PCL. This was never completed, and
+;;;; was removed at that point to make the code easier to understand
+;;;; -- but:
+;;;;
+;;;; FIXME: It would be possible to optimize GF calls inside method
+;;;; bodies using permutation vectors: if all the arguments to the
+;;;; GF are specializers parameters, we can assign a permutation index
+;;;; to each such (GF . ARGS) tuple inside a method body, and use this
+;;;; to cache effective method functions.
 
 (defmacro instance-slot-index (wrapper slot-name)
   `(let ((pos 0))
@@ -33,32 +45,12 @@
          (when (eq ,slot-name sn) (return-from loop pos))
          (incf pos)))))
 
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
+(declaim (inline make-pv-table))
 (defstruct (pv-table (:predicate pv-tablep)
-                     (:constructor make-pv-table-internal
-                                   (slot-name-lists call-list))
                      (:copier nil))
   (cache nil :type (or cache null))
   (pv-size 0 :type fixnum)
-  (slot-name-lists nil :type list)
-  (call-list nil :type list))
-
-#-sb-fluid (declaim (sb-ext:freeze-type pv-table))
-
-;;; FIXME: The comment below seem to indicate that this was intended
-;;; to be actually used, however, it isn't anymore, and was commented
-;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
-;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
-;;;
-;;;   help new slot-value-using-class methods affect fast iv access
-;;;
-;;;  (defvar *all-pv-table-list* nil)
-
-(declaim (inline make-pv-table))
-(defun make-pv-table (&key slot-name-lists call-list)
-  (make-pv-table-internal slot-name-lists call-list))
+  (slot-name-lists nil :type list))
 
 (defun make-pv-table-type-declaration (var)
   `(type pv-table ,var))
@@ -69,30 +61,24 @@
 ;;; Entries in this are lists of (table . pv-offset-list).
 (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
 
-(defun intern-pv-table (&key slot-name-lists call-list)
+(defun intern-pv-table (&key slot-name-lists)
   (let ((new-p nil))
-    (flet ((inner (x)
-             (or (gethash x *slot-name-lists-inner*)
-                 (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
-           (outer (x)
-             (or (gethash x *slot-name-lists-outer*)
-                 (setf (gethash x *slot-name-lists-outer*)
-                       (let ((snl (copy-list (cdr x)))
-                             (cl (car x)))
+    (flet ((inner (slot-names)
+             (or (gethash slot-names *slot-name-lists-inner*)
+                 (setf (gethash slot-names *slot-name-lists-inner*) slot-names)))
+           (outer (snl)
+             (or (gethash snl *slot-name-lists-outer*)
+                 (setf (gethash snl *slot-name-lists-outer*)
+                       (progn
                          (setq new-p t)
-                         (make-pv-table :slot-name-lists snl
-                                        :call-list cl))))))
-      (let ((pv-table
-             (outer (mapcar #'inner (cons call-list slot-name-lists)))))
+                         (make-pv-table :slot-name-lists snl))))))
+      (let ((pv-table (outer (mapcar #'inner slot-name-lists))))
         (when new-p
           (let ((pv-index 0))
             (dolist (slot-name-list slot-name-lists)
               (dolist (slot-name (cdr slot-name-list))
                 (note-pv-table-reference slot-name pv-index pv-table)
                 (incf pv-index)))
-            (dolist (gf-call call-list)
-              (note-pv-table-reference gf-call pv-index pv-table)
-              (incf pv-index))
             (setf (pv-table-pv-size pv-table) pv-index)))
         pv-table))))
 
@@ -157,8 +143,7 @@
   (unless (listp wrappers)
     (setq wrappers (list wrappers)))
   (let (elements)
-    (dolist (slot-names slot-name-lists
-             (make-permutation-vector (nreverse elements)))
+    (dolist (slot-names slot-name-lists)
       (when slot-names
         (let* ((wrapper (pop wrappers))
                (std-p (typep wrapper 'wrapper))
@@ -168,75 +153,35 @@
             (push (if std-p
                       (compute-pv-slot slot-name wrapper class class-slots)
                       nil)
-                  elements)))))))
-
-(defun compute-calls (call-list wrappers)
-  (declare (ignore call-list wrappers))
-  #||
-  (map 'vector
-       (lambda (call)
-         (compute-emf-from-wrappers call wrappers))
-       call-list)
-  ||#
-  '#())
-
-#|| ; Need to finish this, then write the maintenance functions.
-(defun compute-emf-from-wrappers (call wrappers)
-  (when call
-    (destructuring-bind (gf-name nreq restp arg-info) call
-      (if (eq gf-name 'make-instance)
-          (error "should not get here") ; there is another mechanism for this.
-          (lambda (&rest args)
-            (if (not (eq *boot-state* 'complete))
-                (apply (gdefinition gf-name) args)
-                (let* ((gf (gdefinition gf-name))
-                       (arg-info (arg-info-reader gf))
-                       (classes '?)
-                       (types '?)
-                       (emf (cache-miss-values-internal gf arg-info
-                                                        wrappers classes types
-                                                        'caching)))
-                  (update-all-pv-tables call wrappers emf)
-                  (invoke-emf emf args))))))))
-||#
-
-(defun make-permutation-vector (indexes)
-  (make-array (length indexes) :initial-contents indexes))
+                  elements)))))
+    (let* ((n (length elements))
+           (pv (make-array n)))
+      (loop for i from (1- n) downto 0
+         do (setf (svref pv i) (pop elements)))
+      pv)))
 
 (defun pv-table-lookup (pv-table pv-wrappers)
   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
-         (call-list (pv-table-call-list pv-table))
          (cache (or (pv-table-cache pv-table)
                     (setf (pv-table-cache pv-table)
-                          (get-cache (- (length slot-name-lists)
-                                        (count nil slot-name-lists))
-                                     t
-                                     #'pv-cache-limit-fn
-                                     2)))))
-    (or (probe-cache cache pv-wrappers)
-        (let* ((pv (compute-pv slot-name-lists pv-wrappers))
-               (calls (compute-calls call-list pv-wrappers))
-               (pv-cell (cons pv calls))
-               (new-cache (fill-cache cache pv-wrappers pv-cell)))
-          (unless (eq new-cache cache)
-            (setf (pv-table-cache pv-table) new-cache))
-          pv-cell))))
+                          (make-cache :key-count (- (length slot-name-lists)
+                                                    (count nil slot-name-lists))
+                                      :value t
+                                      :size 2)))))
+    (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
+      (if hitp
+          value
+          (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+                 (new-cache (fill-cache cache pv-wrappers pv)))
+            ;; This is safe: if another thread races us here the loser just
+            ;; misses the next time as well.
+            (unless (eq new-cache cache)
+              (setf (pv-table-cache pv-table) new-cache))
+            pv)))))
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))
 
-(defmacro pvref (pv index)
-  `(svref ,pv ,index))
-
-(defmacro copy-pv (pv)
-  `(copy-seq ,pv))
-
-(defun make-calls-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defmacro callsref (calls index)
-  `(svref ,calls ,index))
-
 (defvar *pv-table-cache-update-info* nil)
 
 (defun update-pv-table-cache-info (class)
@@ -283,8 +228,8 @@
               (incf map-index))
             (incf param-index)))
         (when cache
-          (map-cache (lambda (wrappers pv-cell)
-                       (update-slots-in-pv wrappers (car pv-cell)
+          (map-cache (lambda (wrappers pv)
+                       (update-slots-in-pv wrappers pv
                                            cwrapper pv-size pv-map))
                      cache))))))
 
@@ -295,7 +240,7 @@
           (let ((map (svref pv-map i)))
             (when map
               (aver (= (car map) 0))
-              (setf (pvref pv i) (cdr map))))))
+              (setf (svref pv i) (cdr map))))))
       (when (memq cwrapper wrappers)
         (let ((param 0))
           (dolist (wrapper wrappers)
@@ -303,164 +248,119 @@
               (dotimes-fixnum (i pv-size)
                 (let ((map (svref pv-map i)))
                   (when (and map (= (car map) param))
-                    (setf (pvref pv i) (cdr map))))))
+                    (setf (svref pv i) (cdr map))))))
             (incf param))))))
 
-(defun maybe-expand-accessor-form (form required-parameters slots env)
-  (let* ((fname (car form))
-         #||(len (length form))||#
-         (gf (if (symbolp fname)
-                 (unencapsulated-fdefinition fname)
-                 (gdefinition fname))))
-    (macrolet ((maybe-optimize-reader ()
-                 `(let ((parameter
-                         (can-optimize-access1 (cadr form)
-                                               required-parameters env)))
-                   (when parameter
-                     (optimize-reader slots parameter gf-name form))))
-               (maybe-optimize-writer ()
-                 `(let ((parameter
-                         (can-optimize-access1 (caddr form)
-                                               required-parameters env)))
-                   (when parameter
-                     (optimize-writer slots parameter gf-name form)))))
-      (unless (and (consp (cadr form))
-                   (eq 'instance-accessor-parameter (caadr form)))
-        (when (and (eq *boot-state* 'complete)
-                   (generic-function-p gf))
-          (let ((methods (generic-function-methods gf)))
-            (when methods
-              (let* ((gf-name (generic-function-name gf))
-                     (arg-info (gf-arg-info gf))
-                     (metatypes (arg-info-metatypes arg-info))
-                     (nreq (length metatypes))
-                     (applyp (arg-info-applyp arg-info)))
-                (when (null applyp)
-                  (cond ((= nreq 1)
-                         (when (some #'standard-reader-method-p methods)
-                           (maybe-optimize-reader)))
-                        ((and (= nreq 2)
-                              (consp gf-name)
-                              (eq (car gf-name) 'setf))
-                         (when (some #'standard-writer-method-p methods)
-                           (maybe-optimize-writer)))))))))))))
-
-(defun optimize-generic-function-call (form
-                                       required-parameters
-                                       env
-                                       slots
-                                       calls)
-  (declare (ignore required-parameters env slots calls))
-  (or ; (optimize-reader ...)?
-      form))
-
 (defun can-optimize-access (form required-parameters env)
-  (let ((type (ecase (car form)
-                (slot-value 'reader)
-                (set-slot-value 'writer)
-                (slot-boundp 'boundp)))
-        (var (cadr form))
-        (slot-name (eval (caddr form)))) ; known to be constant
-    (can-optimize-access1 var required-parameters env type slot-name)))
-
-;;; FIXME: This looks like an internal helper function for
-;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
-;;; bare from several places in the code. Perhaps the two functions
-;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
-;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
-;;; args instead of optional ones, too.
-(defun can-optimize-access1 (var required-parameters env
-                             &optional type slot-name)
-  (when (and (consp var) (eq 'the (car var)))
-    ;; FIXME: We should assert list of length 3 here. Or maybe we
-    ;; should just define EXTRACT-THE, replace the whole
-    ;;   (WHEN ..)
-    ;; form with
-    ;;   (AWHEN (EXTRACT-THE VAR)
-    ;;     (SETF VAR IT))
-    ;; and then use EXTRACT-THE similarly to clean up the other tests
-    ;; against 'THE scattered through the PCL code.
-    (setq var (caddr var)))
-  (when (symbolp var)
-    (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
-           (parameter-or-nil (car (memq (or rebound? var)
-                                        required-parameters))))
-      (when parameter-or-nil
-        (let* ((class-name (caddr (var-declaration '%class
-                                                   parameter-or-nil
-                                                   env)))
-               (class (find-class class-name nil)))
-          (when (or (not (eq *boot-state* 'complete))
-                    (and class (not (class-finalized-p class))))
-            (setq class nil))
-          (when (and class-name (not (eq class-name t)))
-            (when (or (null type)
-                      (not (and class
-                                (memq *the-class-structure-object*
-                                      (class-precedence-list class))))
-                      (optimize-slot-value-by-class-p class slot-name type))
-              (cons parameter-or-nil (or class class-name)))))))))
-
-(defun optimize-slot-value (slots sparameter form)
-  (if sparameter
-      (destructuring-bind (ignore1 ignore2 slot-name-form) form
-        (declare (ignore ignore1 ignore2))
-        (let ((slot-name (eval slot-name-form)))
-          (optimize-instance-access slots :read sparameter slot-name nil)))
-      `(accessor-slot-value ,@(cdr form))))
-
-(defun optimize-set-slot-value (slots sparameter form)
-  (if sparameter
-      (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
-        (declare (ignore ignore1 ignore2))
-        (let ((slot-name (eval slot-name-form)))
-          (optimize-instance-access slots
-                                    :write
-                                    sparameter
-                                    slot-name
-                                    new-value)))
-      `(accessor-set-slot-value ,@(cdr form))))
-
-(defun optimize-slot-boundp (slots sparameter form)
-  (if sparameter
-      (destructuring-bind
-          ;; FIXME: In CMU CL ca. 19991205, this binding list had a
-          ;; fourth element in it, NEW-VALUE. It's hard to see how
-          ;; that could possibly be right, since SLOT-BOUNDP has no
-          ;; NEW-VALUE. Since it was causing a failure in building PCL
-          ;; for SBCL, so I changed it to match the definition of
-          ;; SLOT-BOUNDP (and also to match the list used in the
-          ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded
-          ;; out by this, since this is old code which has worked for
-          ;; ages to build PCL for CMU CL, so it's hard to see why it
-          ;; should need a patch like this in order to build PCL for
-          ;; SBCL. I'd like to return to this and find a test case
-          ;; which exercises this function both in CMU CL, to see
-          ;; whether it's really a previously-unexercised bug or
-          ;; whether I've misunderstood something (and, presumably,
-          ;; patched it wrong).
-          (slot-boundp-symbol instance slot-name-form)
-          form
-        (declare (ignore slot-boundp-symbol instance))
-        (let ((slot-name (eval slot-name-form)))
-          (optimize-instance-access slots
-                                    :boundp
-                                    sparameter
-                                    slot-name
-                                    nil)))
-      `(accessor-slot-boundp ,@(cdr form))))
-
-(defun optimize-reader (slots sparameter gf-name form)
-  (if sparameter
-      (optimize-accessor-call slots :read sparameter gf-name nil)
-      form))
-
-(defun optimize-writer (slots sparameter gf-name form)
-  (if sparameter
-      (destructuring-bind (ignore1 ignore2 new-value) form
-        (declare (ignore ignore1 ignore2))
-        (optimize-accessor-call slots :write sparameter gf-name new-value))
-      form))
+  (destructuring-bind (op var-form slot-name-form &optional new-value) form
+      (let ((type (ecase op
+                    (slot-value 'reader)
+                    (set-slot-value 'writer)
+                    (slot-boundp 'boundp)))
+            (var (extract-the var-form))
+            (slot-name (constant-form-value slot-name-form env)))
+        (when (symbolp var)
+          (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
+                 (parameter-or-nil (car (memq (or rebound? var)
+                                              required-parameters))))
+            (when parameter-or-nil
+              (let* ((class-name (caddr (var-declaration '%class
+                                                         parameter-or-nil
+                                                         env)))
+                     (class (find-class class-name nil)))
+                (when (or (not (eq *boot-state* 'complete))
+                          (and class (not (class-finalized-p class))))
+                  (setq class nil))
+                (when (and class-name (not (eq class-name t)))
+                  (when (or (null type)
+                            (not (and class
+                                      (memq *the-class-structure-object*
+                                            (class-precedence-list class))))
+                            (optimize-slot-value-by-class-p class slot-name type))
+                    (values (cons parameter-or-nil (or class class-name))
+                            slot-name
+                            new-value))))))))))
+
+;;; Check whether the binding of the named variable is modified in the
+;;; method body.
+(defun parameter-modified-p (parameter-name env)
+  (let ((modified-variables (macroexpand '%parameter-binding-modified env)))
+    (memq parameter-name modified-variables)))
+
+(defun optimize-slot-value (form slots required-parameters env)
+  (multiple-value-bind (sparameter slot-name)
+      (can-optimize-access form required-parameters env)
+    (if sparameter
+        (let ((optimized-form
+               (optimize-instance-access slots :read sparameter
+                                         slot-name nil)))
+             ;; We don't return the optimized form directly, since there's
+             ;; still a chance that we'll find out later on that the
+             ;; optimization should not have been done, for example due to
+             ;; the walker encountering a SETQ on SPARAMETER later on in
+             ;; the body [ see for example clos.impure.lisp test with :name
+             ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
+             ;; the decision until the compiler macroexpands
+             ;; OPTIMIZED-SLOT-VALUE.
+             ;;
+             ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
+             ;; this point (instead of when expanding
+             ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
+             ;; SLOTS. If that mutation isn't done during the walking,
+             ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
+             ;; form around the body, and compilation will fail.  -- JES,
+             ;; 2006-09-18
+             `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
+           `(accessor-slot-value ,@(cdr form)))))
+
+(defmacro optimized-slot-value (form parameter-name optimized-form
+                                &environment env)
+  ;; Either use OPTIMIZED-FORM or fall back to the safe
+  ;; ACCESSOR-SLOT-VALUE.
+  (if (parameter-modified-p parameter-name env)
+      `(accessor-slot-value ,@(cdr form))
+      optimized-form))
+
+(defun optimize-set-slot-value (form slots required-parameters env)
+  (multiple-value-bind (sparameter slot-name new-value)
+      (can-optimize-access form required-parameters env)
+    (if sparameter
+        (let ((optimized-form
+               (optimize-instance-access slots :write sparameter
+                                         slot-name new-value)))
+             ;; See OPTIMIZE-SLOT-VALUE
+             `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
+           `(accessor-set-slot-value ,@(cdr form)))))
+
+(defmacro optimized-set-slot-value (form parameter-name optimized-form
+                                    &environment env)
+  (cond ((safe-code-p env)
+         ;; Don't optimize slot value setting in safe code, since the
+         ;; optimized version will fail to catch some type errors
+         ;; (for example when a subclass declares a tighter type for
+         ;; the slot than a superclass).
+         `(safe-set-slot-value ,@(cdr form)))
+        ((parameter-modified-p parameter-name env)
+         `(accessor-set-slot-value ,@(cdr form)))
+        (t
+         optimized-form)))
+
+(defun optimize-slot-boundp (form slots required-parameters env)
+  (multiple-value-bind (sparameter slot-name)
+      (can-optimize-access form required-parameters env)
+    (if sparameter
+        (let ((optimized-form
+               (optimize-instance-access slots :boundp sparameter
+                                         slot-name nil)))
+          ;; See OPTIMIZE-SLOT-VALUE
+          `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
+        `(accessor-slot-boundp ,@(cdr form)))))
+
+(defmacro optimized-slot-boundp (form parameter-name optimized-form
+                                 &environment env)
+  (if (parameter-modified-p parameter-name env)
+      `(accessor-slot-boundp ,@(cdr form))
+      optimized-form))
 
 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
 ;;; of a required parameter to the function. The alist is in order, so
@@ -508,84 +408,6 @@
              `(instance-boundp ,pv-offset-form ,parameter ,position
                                ',slot-name ',class)))))))
 
-(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
-  (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
-         (parameter (if (consp sparameter) (car sparameter) sparameter))
-         (parameter-entry (assq parameter slots))
-         (name (case read/write
-                 (:read `(reader ,gf-name))
-                 (:write `(writer ,gf-name))))
-         (slot-entry      (assoc name (cdr parameter-entry) :test #'equal))
-         (position (posq parameter-entry slots))
-         (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-    (unless parameter-entry
-      (error "slot optimization bewilderment: O-A-C"))
-    (unless slot-entry
-      (setq slot-entry (list name))
-      (push slot-entry (cdr parameter-entry)))
-    (push pv-offset-form (cdr slot-entry))
-    (ecase read/write
-      (:read
-       `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
-      (:write
-       `(let ((.new-value. ,new-value))
-          (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
-                           .new-value.))))))
-
-(defvar *unspecific-arg* '..unspecific-arg..)
-
-(defun optimize-gf-call-internal (form slots env)
-  (when (and (consp form)
-             (eq (car form) 'the))
-    (setq form (caddr form)))
-  (or (and (symbolp form)
-           (let* ((rebound? (caddr (var-declaration '%variable-rebinding
-                                                    form
-                                                    env)))
-                  (parameter-or-nil (car (assq (or rebound? form) slots))))
-             (when parameter-or-nil
-               (let* ((class-name (caddr (var-declaration 'class
-                                                          parameter-or-nil
-                                                          env))))
-                 (when (and class-name (not (eq class-name t)))
-                   (position parameter-or-nil slots :key #'car))))))
-      (if (constantp form)
-          (let ((form (constant-form-value form)))
-            (if (symbolp form)
-                form
-                *unspecific-arg*))
-          *unspecific-arg*)))
-
-(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
-  (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
-    (let* ((args (cdr gf-call-form))
-           (all-args-p (eq (car gf-call-form) 'make-instance))
-           (non-required-args (nthcdr nreq args))
-           (required-args (ldiff args non-required-args))
-           (call-spec (list (car gf-call-form) nreq restp
-                            (mapcar (lambda (form)
-                                      (optimize-gf-call-internal form slots env))
-                                    (if all-args-p
-                                        args
-                                        required-args))))
-           (call-entry (assoc call-spec calls :test #'equal))
-           (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-      (unless (some #'integerp
-                    (let ((spec-args (cdr call-spec)))
-                      (if all-args-p
-                          (ldiff spec-args (nthcdr nreq spec-args))
-                          spec-args)))
-        (return-from optimize-gf-call nil))
-      (unless call-entry
-        (setq call-entry (list call-spec))
-        (push call-entry (cdr calls)))
-      (push pv-offset-form (cdr call-entry))
-      (if (eq (car call-spec) 'make-instance)
-          `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
-          `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
-            (invoke-effective-method-function .emf. ,restp
-             ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
-
 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
 (defmacro pv-offset (arg) arg)
 (define-walker-template instance-accessor-parameter)
@@ -610,26 +432,21 @@
     (and (eq *boot-state* 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
+         ;; FIXME: Is this really right? "Don't skip if there is
+         ;; no slot definition."
          (let ((slotd (find-slot-definition class slot-name)))
-           (and slotd (skip-optimize-slot-value-by-class-p class
-                                                           slot-name
-                                                           type))))))
-
-(defun skip-optimize-slot-value-by-class-p (class slot-name type)
-  (let ((slotd (find-slot-definition class slot-name)))
-    (and slotd
-         (eq *boot-state* 'complete)
-         (not (slot-accessor-std-p slotd type)))))
-
-(defmacro instance-read-internal (pv slots pv-offset default &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
-  (if (eq type :default)
+           (and slotd
+                (not (slot-accessor-std-p slotd type)))))))
+
+(defmacro instance-read-internal (pv slots pv-offset default &optional kind)
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym))
              (value index))
         `(locally (declare #.*optimize-speed*)
-          (let ((,index (pvref ,pv ,pv-offset)))
+          (let ((,index (svref ,pv ,pv-offset)))
             (setq ,value (typecase ,index
                            ;; FIXME: the line marked by KLUDGE below
                            ;; (and the analogous spot in
@@ -642,11 +459,11 @@
                            ;; to shut it up.  (see also mail Rudi
                            ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
                            ;; 2003-11-30
-                           ,@(when (or (null type) (eq type :instance))
+                           ,@(when (or (null kind) (eq kind :instance))
                                `((fixnum
                                   (and ,slots ; KLUDGE
                                    (clos-slots-ref ,slots ,index)))))
-                           ,@(when (or (null type) (eq type :class))
+                           ,@(when (or (null kind) (eq kind :class))
                                `((cons (cdr ,index))))
                            (t +slot-unbound+)))
             (if (eq ,value +slot-unbound+)
@@ -661,28 +478,21 @@
         ,(if (generate-fast-class-slot-access-p class slot-name)
              :class :instance))))
 
-(defmacro instance-reader (pv-offset parameter position gf-name class)
-  (declare (ignore class))
-  `(instance-read-internal .pv. ,(slot-vector-symbol position)
-    ,pv-offset
-    (,gf-name (instance-accessor-parameter ,parameter))
-    :instance))
-
 (defmacro instance-write-internal (pv slots pv-offset new-value default
-                                      &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
-  (if (eq type :default)
+                                      &optional kind)
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym)))
         `(locally (declare #.*optimize-speed*)
-          (let ((,index (pvref ,pv ,pv-offset)))
+          (let ((,index (svref ,pv ,pv-offset)))
             (typecase ,index
-              ,@(when (or (null type) (eq type :instance))
+              ,@(when (or (null kind) (eq kind :instance))
                   `((fixnum (and ,slots
                              (setf (clos-slots-ref ,slots ,index)
                                    ,new-value)))))
-              ,@(when (or (null type) (eq type :class))
+              ,@(when (or (null kind) (eq kind :class))
                   `((cons (setf (cdr ,index) ,new-value))))
               (t ,default)))))))
 
@@ -700,37 +510,21 @@
         ,(if (generate-fast-class-slot-access-p class slot-name)
              :class :instance))))
 
-(defmacro instance-writer (pv-offset
-                           parameter
-                           position
-                           gf-name
-                           class
-                           new-value)
-  (declare (ignore class))
-  `(instance-write-internal .pv. ,(slot-vector-symbol position)
-    ,pv-offset ,new-value
-    (,(if (consp gf-name)
-          (get-setf-fun-name gf-name)
-          gf-name)
-     (instance-accessor-parameter ,parameter)
-     ,new-value)
-    :instance))
-
 (defmacro instance-boundp-internal (pv slots pv-offset default
-                                       &optional type)
-  (unless (member type '(nil :instance :class :default))
-    (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
-  (if (eq type :default)
+                                       &optional kind)
+  (unless (member kind '(nil :instance :class :default))
+    (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
+  (if (eq kind :default)
       default
       (let* ((index (gensym)))
         `(locally (declare #.*optimize-speed*)
-          (let ((,index (pvref ,pv ,pv-offset)))
+          (let ((,index (svref ,pv ,pv-offset)))
             (typecase ,index
-              ,@(when (or (null type) (eq type :instance))
+              ,@(when (or (null kind) (eq kind :instance))
                   `((fixnum (not (and ,slots
                                       (eq (clos-slots-ref ,slots ,index)
                                           +slot-unbound+))))))
-              ,@(when (or (null type) (eq type :class))
+              ,@(when (or (null kind) (eq kind :class))
                   `((cons (not (eq (cdr ,index) +slot-unbound+)))))
               (t ,default)))))))
 
@@ -758,51 +552,26 @@
 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
 ;;; having fewer PV's floating around. Even if the gain is only
 ;;; modest, it costs nothing.
-(defun slot-name-lists-from-slots (slots calls)
-  (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
+(defun slot-name-lists-from-slots (slots)
+  (let ((slots (mutate-slots slots)))
     (let* ((slot-name-lists
             (mapcar (lambda (parameter-entry)
                       (cons nil (mapcar #'car (cdr parameter-entry))))
-                    slots))
-           (call-list
-            (mapcar #'car calls)))
-      (dolist (call call-list)
-        (dolist (arg (cdr call))
-          (when (integerp arg)
-            (setf (car (nth arg slot-name-lists)) t))))
-      (setq slot-name-lists (mapcar (lambda (r+snl)
-                                      (when (or (car r+snl) (cdr r+snl))
-                                        r+snl))
-                                    slot-name-lists))
-      (let ((cvt (apply #'vector
-                        (let ((i -1))
-                          (mapcar (lambda (r+snl)
-                                    (when r+snl (incf i)))
-                                  slot-name-lists)))))
-        (setq call-list (mapcar (lambda (call)
-                                  (cons (car call)
-                                        (mapcar (lambda (arg)
-                                                  (if (integerp arg)
-                                                      (svref cvt arg)
-                                                      arg))
-                                                (cdr call))))
-                                call-list)))
-      (values slot-name-lists call-list))))
-
-(defun mutate-slots-and-calls (slots calls)
+                    slots)))
+      (mapcar (lambda (r+snl)
+                (when (or (car r+snl) (cdr r+snl))
+                  r+snl))
+              slot-name-lists))))
+
+(defun mutate-slots (slots)
   (let ((sorted-slots (sort-slots slots))
-        (sorted-calls (sort-calls (cdr calls)))
         (pv-offset -1))
     (dolist (parameter-entry sorted-slots)
       (dolist (slot-entry (cdr parameter-entry))
         (incf pv-offset)
         (dolist (form (cdr slot-entry))
           (setf (cadr form) pv-offset))))
-    (dolist (call-entry sorted-calls)
-      (incf pv-offset)
-      (dolist (form (cdr call-entry))
-        (setf (cadr form) pv-offset)))
-    (values sorted-slots sorted-calls)))
+    sorted-slots))
 
 (defun symbol-pkg-name (sym)
   (let ((pkg (symbol-package sym)))
@@ -847,8 +616,6 @@
                         :key #'car)))
           slots))
 
-(defun sort-calls (calls)
-  (sort calls #'symbol-or-cons-lessp :key #'car))
 
 ;;;; This needs to work in terms of metatypes and also needs to work
 ;;;; for automatically generated reader and writer functions.
@@ -864,13 +631,13 @@
           do (when slots
                (push required-parameter pv-parameters)
                (push (slot-vector-symbol i) slot-vars)))
-    `(pv-binding1 (.pv. .calls. ,pv-table-form
+    `(pv-binding1 (,pv-table-form
                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
        ,@body)))
 
-(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
+(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars)
                        &body body)
-  `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
+  `(pv-env (,pv-table-form ,pv-parameters)
      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
                      slot-vars pv-parameters))
        (declare (ignorable ,@(mapcar #'identity slot-vars)))
@@ -881,24 +648,15 @@
 (define-symbol-macro pv-env-environment overridden)
 
 (defmacro pv-env (&environment env
-                  (pv calls pv-table-form pv-parameters)
+                  (pv-table-form pv-parameters)
                   &rest forms)
   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
   ;; symbol-macrolet.
   (if (eq (macroexpand 'pv-env-environment env) 'default)
-      `(let ((,pv (car .pv-cell.))
-             (,calls (cdr .pv-cell.)))
-         (declare ,(make-pv-type-declaration pv)
-                  ,(make-calls-type-declaration calls))
-         ,pv ,calls
-         ,@forms)
+      `(locally ,@forms)
       `(let* ((.pv-table. ,pv-table-form)
-              (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
-              (,pv (car .pv-cell.))
-              (,calls (cdr .pv-cell.)))
-        (declare ,(make-pv-type-declaration pv))
-        (declare ,(make-calls-type-declaration calls))
-        ,pv ,calls
+              (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
+        (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
 (defvar *non-var-declarations*
@@ -911,6 +669,7 @@
     %method-lambda-list
     optimize
     ftype
+    muffle-conditions
     inline
     notinline))
 
@@ -1055,38 +814,91 @@
           (make-method-initargs-form-internal1
            initargs (cddr lmf) args lmf-params restp)))))
 
+(defun lambda-list-parameter-names (lambda-list)
+  ;; Given a valid lambda list, extract the parameter names.
+  (loop for x in lambda-list
+        with res = nil
+        do (unless (member x lambda-list-keywords)
+             (if (consp x)
+                 (let ((name (car x)))
+                   (if (consp name)
+                       ;; ... ((:BAR FOO) 1)
+                       (push (second name) res)
+                       ;; ... (FOO 1)
+                       (push name res))
+                   ;; ... (... 1 FOO-P)
+                   (let ((name-p (cddr x)))
+                     (when name-p
+                       (push (car name-p) res))))
+                 ;; ... FOO
+                 (push x res)))
+        finally (return res)))
+
 (defun make-method-initargs-form-internal1
     (initargs body req-args lmf-params restp)
-  (multiple-value-bind (outer-decls inner-decls body-sans-decls)
-      (split-declarations
-       body req-args (or (getf (cdr lmf-params) :call-next-method-p)
-                         (getf (cdr lmf-params) :setq-p)))
-    (let* ((rest-arg (when restp '.rest-arg.))
-           (args+rest-arg (if restp
-                              (append req-args (list rest-arg))
-                              req-args)))
-      `(list*
-        :function
-        (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
-                     ,@(when (body-method-name body)
-                         ;; function name
-                         (list (cons 'fast-method (body-method-name body))))
-                     (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
-                     ;; body of the function
-                     (declare (ignorable .pv-cell. .next-method-call.)
-                              (disable-package-locks pv-env-environment))
-                     ,@outer-decls
-                     (symbol-macrolet ((pv-env-environment default))
-                         (fast-lexical-method-functions
-                          (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
-                            ,@(cdddr lmf-params))
-                          ,@inner-decls
-                          ,@body-sans-decls))))
-              (mf (%make-method-function fmf nil)))
-          (set-funcallable-instance-function
-           mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
-          mf)
-        ',initargs))))
+  (let* (;; The lambda-list of the method, minus specifiers
+         (lambda-list (car lmf-params))
+         ;; Names of the parameters that will be in the outermost lambda-list
+         ;; (and whose bound declarations thus need to be in OUTER-DECLS).
+         (outer-parameters req-args)
+         ;; The lambda-list used by BIND-ARGS
+         (bind-list lambda-list)
+         (setq-p (getf (cdr lmf-params) :setq-p))
+         (auxp (member '&aux bind-list))
+         (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
+    ;; Try to use the normal function call machinery instead of BIND-ARGS
+    ;; binding the arguments, unless:
+    (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
+                ;; in any case.
+                (and (not restp) (not auxp))
+                ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
+                ;; list of all non-required arguments.
+                call-next-method-p)
+      (setf ;; We don't want a binding for .REST-ARG.
+            restp nil
+            ;; Get all the parameters for declaration parsing
+            outer-parameters (lambda-list-parameter-names lambda-list)
+            ;; Ensure that BIND-ARGS won't do anything (since
+            ;; BIND-LIST won't contain any non-required parameters,
+            ;; and REQ-ARGS will be of an equal length). We still want
+            ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
+            ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
+            ;; of rebinding SETQd required arguments around the method
+            ;; body.
+            bind-list req-args))
+    (multiple-value-bind (outer-decls inner-decls body-sans-decls)
+        (split-declarations
+         body outer-parameters (or call-next-method-p setq-p))
+      (let* ((rest-arg (when restp
+                         '.rest-arg.))
+             (fmf-lambda-list (if rest-arg
+                                  (append req-args (list '&rest rest-arg))
+                                  (if call-next-method-p
+                                      req-args
+                                      lambda-list))))
+        `(list*
+          :function
+          (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
+                        ,@(when (body-method-name body)
+                                ;; function name
+                                (list (cons 'fast-method (body-method-name body))))
+                        ;; The lambda-list of the FMF
+                        (.pv. .next-method-call. ,@fmf-lambda-list)
+                        ;; body of the function
+                        (declare (ignorable .pv. .next-method-call.)
+                                 (disable-package-locks pv-env-environment))
+                        ,@outer-decls
+                        (symbol-macrolet ((pv-env-environment default))
+                          (fast-lexical-method-functions
+                              (,bind-list .next-method-call. ,req-args ,rest-arg
+                                ,@(cdddr lmf-params))
+                            ,@inner-decls
+                            ,@body-sans-decls))))
+                 (mf (%make-method-function fmf nil)))
+            (set-funcallable-instance-function
+             mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
+            mf)
+          ',initargs)))))
 
 ;;; Use arrays and hash tables and the fngen stuff to make this much
 ;;; better. It doesn't really matter, though, because a function
@@ -1096,17 +908,16 @@
 (defun method-function-from-fast-function (fmf plist)
   (declare (type function fmf))
   (let* ((method-function nil)
-         (calls (getf plist :call-list))
          (snl (getf plist :slot-name-lists))
-         (pv-table (when (or calls snl)
-                     (intern-pv-table :call-list calls :slot-name-lists snl)))
+         (pv-table (when snl
+                     (intern-pv-table :slot-name-lists snl)))
          (arg-info (getf plist :arg-info))
          (nreq (car arg-info))
          (restp (cdr arg-info)))
     (setq method-function
           (lambda (method-args next-methods)
-            (let* ((pv-cell (when pv-table
-                              (get-pv-cell method-args pv-table)))
+            (let* ((pv (when pv-table
+                         (get-pv method-args pv-table)))
                    (nm (car next-methods))
                    (nms (cdr next-methods))
                    (nmc (when nm
@@ -1115,11 +926,7 @@
                                          (method-function nm)
                                          nm)
                            :call-method-args (list nms)))))
-              (if restp
-                  (let* ((rest (nthcdr nreq method-args))
-                         (args (ldiff method-args rest)))
-                    (apply fmf pv-cell nmc (nconc args (list rest))))
-                  (apply fmf pv-cell nmc method-args)))))
+              (apply fmf pv nmc method-args))))
     ;; FIXME: this looks dangerous.
     (let* ((fname (%fun-name fmf)))
       (when (and fname (eq (car fname) 'fast-method))
@@ -1132,7 +939,7 @@
 ;;; over the actual PV-CELL in this case.
 (defun method-function-from-fast-method-call (fmc)
   (let* ((fmf (fast-method-call-function fmc))
-         (pv-cell (fast-method-call-pv-cell fmc))
+         (pv (fast-method-call-pv fmc))
          (arg-info (fast-method-call-arg-info fmc))
          (nreq (car arg-info))
          (restp (cdr arg-info)))
@@ -1145,13 +952,9 @@
                                    (method-function nm)
                                    nm)
                      :call-method-args (list nms)))))
-        (if restp
-            (let* ((rest (nthcdr nreq method-args))
-                   (args (ldiff method-args rest)))
-              (apply fmf pv-cell nmc (nconc args (list rest))))
-            (apply fmf pv-cell nmc method-args))))))
+        (apply fmf pv nmc method-args)))))
 
-(defun get-pv-cell (method-args pv-table)
+(defun get-pv (method-args pv-table)
   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
     (when pv-wrappers
       (pv-table-lookup pv-table pv-wrappers))))
@@ -1181,3 +984,4 @@
         when snl
           collect w into result
         finally (return (if (cdr result) result (car result)))))
+