1.0.45.19: more comprehensive CTOR optimization, part 2

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

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 606acba..696f472 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -81,7 +81,7 @@
       (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
 \f
 (defun optimize-slot-value-by-class-p (class slot-name type)
-  (or (not (eq *boot-state* 'complete))
+  (or (not (eq **boot-state** 'complete))
       (let ((slotd (find-slot-definition class slot-name)))
         (and slotd
              (slot-accessor-std-p slotd type)))))
@@ -155,7 +155,7 @@
                                                          parameter-or-nil
                                                          env)))
                      (class (find-class class-name nil)))
-                (when (or (not (eq *boot-state* 'complete))
+                (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)))
@@ -255,7 +255,7 @@
                                  new-value &optional safep)
   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
         (parameter (if (consp sparameter) (car sparameter) sparameter)))
-    (if (and (eq *boot-state* 'complete)
+    (if (and (eq **boot-state** 'complete)
              (classp class)
              (memq *the-class-structure-object* (class-precedence-list class)))
         (let ((slotd (find-slot-definition class slot-name)))
@@ -301,7 +301,7 @@
   (let ((class (and (constantp class-form) (constant-form-value class-form)))
         (slot-name (and (constantp slot-name-form)
                         (constant-form-value slot-name-form))))
-    (and (eq *boot-state* 'complete)
+    (and (eq **boot-state** 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
          (let ((slotd (find-slot-definition class slot-name)))
@@ -311,7 +311,7 @@
   (let ((class (and (constantp class-form) (constant-form-value class-form)))
         (slot-name (and (constantp slot-name-form)
                         (constant-form-value slot-name-form))))
-    (and (eq *boot-state* 'complete)
+    (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
@@ -550,7 +550,7 @@
         (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
-(defun split-declarations (body args maybe-reads-params-p)
+(defun split-declarations (body args req-args cnm-p parameters-setqd)
   (let ((inner-decls nil)
         (outer-decls nil)
         decl)
@@ -579,7 +579,7 @@
                            ;; args when a next-method is involved, to
                            ;; prevent compiler warnings about ignored
                            ;; args being read.
-                           (unless (and (eq 'ignore name) maybe-reads-params-p)
+                           (unless (and (eq 'ignore name) (member var req-args :test #'eq) (or cnm-p (member var parameters-setqd)))
                              (push var outers))
                            (push var inners)))
                      (when outers
@@ -593,17 +593,6 @@
       (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
-;;; Pull a name out of the %METHOD-NAME declaration in the function
-;;; body given, or return NIL if no %METHOD-NAME declaration is found.
-(defun body-method-name (body)
-  (multiple-value-bind (real-body declarations documentation)
-      (parse-body body)
-    (declare (ignore real-body documentation))
-    (let ((name-decl (get-declaration '%method-name declarations)))
-      (and name-decl
-           (destructuring-bind (name) name-decl
-             name)))))
-
 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
 ;;; declaration (which is a naming style internal to PCL) into an
 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
@@ -611,9 +600,9 @@
 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
 ;;; lambda expression.
 (defun name-method-lambda (method-lambda)
-  (let ((method-name (body-method-name (cddr method-lambda))))
+  (let ((method-name *method-name*))
     (if method-name
-        `(named-lambda (slow-method ,method-name) ,(rest method-lambda))
+        `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda))
         method-lambda)))
 
 (defun make-method-initargs-form-internal (method-lambda initargs env)
@@ -677,7 +666,7 @@
          (outer-parameters req-args)
          ;; The lambda-list used by BIND-ARGS
          (bind-list lambda-list)
-         (setq-p (getf (cdr lmf-params) :setq-p))
+         (parameters-setqd (getf (cdr lmf-params) :parameters-setqd))
          (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
@@ -702,7 +691,7 @@
             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))
+         body outer-parameters req-args call-next-method-p parameters-setqd)
       (let* ((rest-arg (when restp
                          '.rest-arg.))
              (fmf-lambda-list (if rest-arg
@@ -712,10 +701,10 @@
                                       lambda-list))))
         `(list*
           :function
-          (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
-                        ,@(when (body-method-name body)
+          (let* ((fmf (,(if *method-name* 'named-lambda 'lambda)
+                        ,@(when *method-name*
                                 ;; function name
-                                (list (cons 'fast-method (body-method-name body))))
+                                (list `(fast-method ,@*method-name*)))
                         ;; The lambda-list of the FMF
                         (.pv. .next-method-call. ,@fmf-lambda-list)
                         ;; body of the function