X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=02700ecfff151907e7d4db047caabe0928b8cf06;hb=95f17ca63742f8c164309716b35bc25545a849a6;hp=ea6ea96019f81b659e03b9fd5649c1f7a37f3ac9;hpb=c1d63b850fe9528036f8ae715088384e81d880cc;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index ea6ea96..02700ec 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -37,102 +37,48 @@
 ;;;; 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))
-     (declare (fixnum pos))
-     (block loop
-       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
-         (when (eq ,slot-name sn) (return-from loop pos))
-         (incf pos)))))
-
+(declaim (inline make-pv-table))
 (defstruct (pv-table (:predicate pv-tablep)
-                     (:constructor make-pv-table-internal
-                                   (slot-name-lists))
                      (:copier nil))
   (cache nil :type (or cache null))
   (pv-size 0 :type fixnum)
   (slot-name-lists 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)
-  (make-pv-table-internal slot-name-lists))
-
 (defun make-pv-table-type-declaration (var)
   `(type pv-table ,var))
 
-(defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
-(defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
+;;; Used for interning parts of SLOT-NAME-LISTS, as part of
+;;; PV-TABLE interning -- just to save space.
+(defvar *slot-name-lists* (make-hash-table :test 'equal))
+
+;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
+;;; used.
+(defvar *pv-tables* (make-hash-table :test 'equal))
 
-;;; Entries in this are lists of (table . pv-offset-list).
-(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
+;;; ...and one lock to rule them. Spinlock because for certain (rare)
+;;; cases this lock might be grabbed in the course of method dispatch
+;;; -- and mostly this is already under the *world-lock*
+(defvar *pv-lock*
+  (sb-thread::make-spinlock :name "pv table index lock"))
 
 (defun intern-pv-table (&key slot-name-lists)
-  (let ((new-p nil))
-    (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))))))
-      (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)))
-            (setf (pv-table-pv-size pv-table) pv-index)))
-        pv-table))))
-
-(defun note-pv-table-reference (ref pv-offset pv-table)
-  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
-    (when (listp entry)
-      (let ((table-entry (assq pv-table entry)))
-        (when (and (null table-entry)
-                   (> (length entry) 8))
-          (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
-            (dolist (table-entry entry)
-              (setf (gethash (car table-entry) new-table-table)
-                    (cdr table-entry)))
-            (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
-        (when (listp entry)
-          (if (null table-entry)
-              (let ((new (cons pv-table pv-offset)))
-                (if (consp entry)
-                    (push new (cdr entry))
-                    (setf (gethash ref *pv-key-to-pv-table-table*)
-                          (list new))))
-              (push pv-offset (cdr table-entry)))
-          (return-from note-pv-table-reference nil))))
-    (let ((list (gethash pv-table entry)))
-      (if (consp list)
-          (push pv-offset (cdr list))
-          (setf (gethash pv-table entry) (list pv-offset)))))
-  nil)
-
-(defun map-pv-table-references-of (ref function)
-  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
-    (if (listp entry)
-        (dolist (table+pv-offset-list entry)
-          (funcall function
-                   (car table+pv-offset-list)
-                   (cdr table+pv-offset-list)))
-        (maphash function entry)))
-  ref)
+  (flet ((intern-slot-names (slot-names)
+           ;; FIXME: NIL at the head of the list is a remnant from
+           ;; old purged code, that hasn't been quite cleaned up yet.
+           ;; ...but as long as we assume it is there, we may as well
+           ;; assert it.
+           (aver (not (car slot-names)))
+           (or (gethash slot-names *slot-name-lists*)
+               (setf (gethash slot-names *slot-name-lists*) slot-names)))
+         (%intern-pv-table (snl)
+           (or (gethash snl *pv-tables*)
+               (setf (gethash snl *pv-tables*)
+                     (make-pv-table :slot-name-lists snl
+                                    :pv-size (* 2 (reduce #'+ snl
+                                                          :key (lambda (slots)
+                                                                 (length (cdr slots))))))))))
+    (sb-thread::with-spinlock (*pv-lock*)
+      (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
 
 (defun optimize-slot-value-by-class-p (class slot-name type)
   (or (not (eq *boot-state* 'complete))
@@ -140,20 +86,13 @@
         (and slotd
              (slot-accessor-std-p slotd type)))))
 
-(defun compute-pv-slot (slot-name wrapper class class-slots)
-  (if (symbolp slot-name)
-      (when (optimize-slot-value-by-class-p class slot-name 'all)
-        (or (instance-slot-index wrapper slot-name)
-            (assq slot-name class-slots)))
-      (when (consp slot-name)
-        (case (first slot-name)
-          ((reader writer)
-           (when (eq *boot-state* 'complete)
-             (let ((gf (gdefinition (second slot-name))))
-               (when (generic-function-p gf)
-                 (accessor-values1 gf (first slot-name) class)))))
-          (t (bug "Don't know how to deal with ~S in ~S"
-                  slot-name 'compute-pv-slots))))))
+(defun compute-slot-location-for-pv (slot-name wrapper class)
+  (when (optimize-slot-value-by-class-p class slot-name 'all)
+    (car (find-slot-cell wrapper slot-name))))
+
+(defun compute-slot-typecheckfun-for-pv (slot-name wrapper class)
+  (when (optimize-slot-value-by-class-p class slot-name 'all)
+    (cadr (find-slot-cell wrapper slot-name))))
 
 (defun compute-pv (slot-name-lists wrappers)
   (unless (listp wrappers)
@@ -163,12 +102,13 @@
       (when slot-names
         (let* ((wrapper (pop wrappers))
                (std-p (typep wrapper 'wrapper))
-               (class (wrapper-class* wrapper))
-               (class-slots (and std-p (wrapper-class-slots wrapper))))
+               (class (wrapper-class* wrapper)))
           (dolist (slot-name (cdr slot-names))
-            (push (if std-p
-                      (compute-pv-slot slot-name wrapper class class-slots)
-                      nil)
+            (push (when std-p
+                    (compute-slot-location-for-pv slot-name wrapper class))
+                  elements)
+            (push (when std-p
+                    (compute-slot-typecheckfun-for-pv slot-name wrapper class))
                   elements)))))
     (let* ((n (length elements))
            (pv (make-array n)))
@@ -197,75 +137,6 @@
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))
-
-(defvar *pv-table-cache-update-info* nil)
-
-(defun update-pv-table-cache-info (class)
-  (let ((slot-names-for-pv-table-update nil)
-        (new-icui nil))
-    (dolist (icu *pv-table-cache-update-info*)
-      (if (eq (car icu) class)
-          (pushnew (cdr icu) slot-names-for-pv-table-update)
-          (push icu new-icui)))
-    (setq *pv-table-cache-update-info* new-icui)
-    (when slot-names-for-pv-table-update
-      (update-all-pv-table-caches class slot-names-for-pv-table-update))))
-
-(defun update-all-pv-table-caches (class slot-names)
-  (let* ((cwrapper (class-wrapper class))
-         (std-p (typep cwrapper 'wrapper))
-         (class-slots (and std-p (wrapper-class-slots cwrapper)))
-         (new-values
-          (mapcar
-           (lambda (slot-name)
-             (cons slot-name
-                   (if std-p
-                       (compute-pv-slot slot-name cwrapper class class-slots)
-                       nil)))
-           slot-names))
-         (pv-tables nil))
-    (dolist (slot-name slot-names)
-      (map-pv-table-references-of
-       slot-name
-       (lambda (pv-table pv-offset-list)
-         (declare (ignore pv-offset-list))
-         (pushnew pv-table pv-tables))))
-    (dolist (pv-table pv-tables)
-      (let* ((cache (pv-table-cache pv-table))
-             (slot-name-lists (pv-table-slot-name-lists pv-table))
-             (pv-size (pv-table-pv-size pv-table))
-             (pv-map (make-array pv-size :initial-element nil)))
-        (let ((map-index 0) (param-index 0))
-          (dolist (slot-name-list slot-name-lists)
-            (dolist (slot-name (cdr slot-name-list))
-              (let ((a (assoc slot-name new-values)))
-                (setf (svref pv-map map-index)
-                      (and a (cons param-index (cdr a)))))
-              (incf map-index))
-            (incf param-index)))
-        (when cache
-          (map-cache (lambda (wrappers pv)
-                       (update-slots-in-pv wrappers pv
-                                           cwrapper pv-size pv-map))
-                     cache))))))
-
-(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
-  (if (atom wrappers)
-      (when (eq cwrapper wrappers)
-        (dotimes-fixnum (i pv-size)
-          (let ((map (svref pv-map i)))
-            (when map
-              (aver (= (car map) 0))
-              (setf (svref pv i) (cdr map))))))
-      (when (memq cwrapper wrappers)
-        (let ((param 0))
-          (dolist (wrapper wrappers)
-            (when (eq wrapper cwrapper)
-              (dotimes-fixnum (i pv-size)
-                (let ((map (svref pv-map i)))
-                  (when (and map (= (car map) param))
-                    (setf (svref pv i) (cdr map))))))
-            (incf param))))))
 
 (defun can-optimize-access (form required-parameters env)
   (destructuring-bind (op var-form slot-name-form &optional new-value) form
@@ -343,21 +214,19 @@
     (if sparameter
         (let ((optimized-form
                (optimize-instance-access slots :write sparameter
-                                         slot-name new-value)))
+                                         slot-name new-value (safe-code-p env))))
              ;; 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)))
+  (cond ((parameter-modified-p parameter-name env)
+         ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking,
+         ;; so we need to use SAFE-SET-SLOT-VALUE.
+         (if (safe-code-p env)
+             `(safe-set-slot-value ,@(cdr form)))
+             `(accessor-set-slot-value ,@(cdr form)))
         (t
          optimized-form)))
 
@@ -382,11 +251,8 @@
 ;;; of a required parameter to the function. The alist is in order, so
 ;;; the position of an entry in the alist corresponds to the
 ;;; argument's position in the lambda list.
-(defun optimize-instance-access (slots
-                                 read/write
-                                 sparameter
-                                 slot-name
-                                 new-value)
+(defun optimize-instance-access (slots read/write sparameter slot-name
+                                 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)
@@ -419,7 +285,7 @@
             (:write
              `(let ((.new-value. ,new-value))
                 (instance-write ,pv-offset-form ,parameter ,position
-                                ',slot-name ',class .new-value.)))
+                                ',slot-name ',class .new-value. ,safep)))
             (:boundp
              `(instance-boundp ,pv-offset-form ,parameter ,position
                                ',slot-name ',class)))))))
@@ -455,36 +321,33 @@
                 (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))
+  (unless (member kind '(nil :instance :class))
     (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 (svref ,pv ,pv-offset)))
-            (setq ,value (typecase ,index
-                           ;; FIXME: the line marked by KLUDGE below
-                           ;; (and the analogous spot in
-                           ;; INSTANCE-WRITE-INTERNAL) is there purely
-                           ;; to suppress a type mismatch warning that
-                           ;; propagates through to user code.
-                           ;; Presumably SLOTS at this point can never
-                           ;; actually be NIL, but the compiler seems
-                           ;; to think it could, so we put this here
-                           ;; to shut it up.  (see also mail Rudi
-                           ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
-                           ;; 2003-11-30
-                           ,@(when (or (null kind) (eq kind :instance))
-                               `((fixnum
-                                  (and ,slots ; KLUDGE
-                                   (clos-slots-ref ,slots ,index)))))
-                           ,@(when (or (null kind) (eq kind :class))
-                               `((cons (cdr ,index))))
-                           (t +slot-unbound+)))
-            (if (eq ,value +slot-unbound+)
-                ,default
-                ,value))))))
+  (let* ((index (gensym))
+         (value index))
+    `(locally (declare #.*optimize-speed*)
+       (let ((,index (svref ,pv ,pv-offset)))
+         (setq ,value (typecase ,index
+                        ;; FIXME: the line marked by KLUDGE below (and
+                        ;; the analogous spot in
+                        ;; INSTANCE-WRITE-INTERNAL) is there purely to
+                        ;; suppress a type mismatch warning that
+                        ;; propagates through to user code.
+                        ;; Presumably SLOTS at this point can never
+                        ;; actually be NIL, but the compiler seems to
+                        ;; think it could, so we put this here to shut
+                        ;; it up.  (see also mail Rudi Schlatte
+                        ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30
+                        ,@(when (or (null kind) (eq kind :instance))
+                                `((fixnum
+                                   (and ,slots ; KLUDGE
+                                        (clos-slots-ref ,slots ,index)))))
+                        ,@(when (or (null kind) (eq kind :class))
+                                `((cons (cdr ,index))))
+                        (t +slot-unbound+)))
+         (if (eq ,value +slot-unbound+)
+             ,default
+             ,value)))))
 
 (defmacro instance-read (pv-offset parameter position slot-name class)
   (if (skip-fast-slot-access-p class slot-name 'reader)
@@ -495,54 +358,63 @@
              :class :instance))))
 
 (defmacro instance-write-internal (pv slots pv-offset new-value default
-                                      &optional kind)
-  (unless (member kind '(nil :instance :class :default))
+                                   &optional kind safep)
+  (unless (member kind '(nil :instance :class))
     (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 (svref ,pv ,pv-offset)))
-            (typecase ,index
-              ,@(when (or (null kind) (eq kind :instance))
-                  `((fixnum (and ,slots
-                             (setf (clos-slots-ref ,slots ,index)
-                                   ,new-value)))))
-              ,@(when (or (null kind) (eq kind :class))
-                  `((cons (setf (cdr ,index) ,new-value))))
-              (t ,default)))))))
-
-(defmacro instance-write (pv-offset
-                          parameter
-                          position
-                          slot-name
-                          class
-                          new-value)
+  (let* ((index (gensym))
+         (new-value-form
+          (if safep
+              `(let ((.typecheckfun. (svref ,pv (1+ ,pv-offset))))
+                 (declare (type (or function null) .typecheckfun.))
+                 (if .typecheckfun.
+                     (funcall .typecheckfun. ,new-value)
+                     ,new-value))
+              new-value)))
+    `(locally (declare #.*optimize-speed*)
+       (let ((.good-new-value. ,new-value-form)
+             (,index (svref ,pv ,pv-offset)))
+         (typecase ,index
+           ,@(when (or (null kind) (eq kind :instance))
+                   `((fixnum (and ,slots
+                                  (setf (clos-slots-ref ,slots ,index)
+                                        .good-new-value.)))))
+           ,@(when (or (null kind) (eq kind :class))
+                   `((cons (setf (cdr ,index) .good-new-value.))))
+           (t ,default))))))
+
+(defmacro instance-write (pv-offset parameter position slot-name class new-value
+                          &optional check-type-p)
   (if (skip-fast-slot-access-p class slot-name 'writer)
-      `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
-      `(instance-write-internal .pv. ,(slot-vector-symbol position)
+      (if check-type-p
+          ;; FIXME: We don't want this here. If it's _possible_ the fast path
+          ;; is applicable, we wan to use it as well.
+          `(safe-set-slot-value ,parameter ,slot-name ,new-value)
+          `(accessor-set-slot-value ,parameter ,slot-name ,new-value))
+      `(instance-write-internal
+        .pv. ,(slot-vector-symbol position)
         ,pv-offset ,new-value
-        (accessor-set-slot-value ,parameter ,slot-name ,new-value)
+        ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
+        ;; is executed (if it is executed).
+        (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
         ,(if (generate-fast-class-slot-access-p class slot-name)
-             :class :instance))))
+             :class :instance)
+        ,check-type-p)))
 
 (defmacro instance-boundp-internal (pv slots pv-offset default
-                                       &optional kind)
-  (unless (member kind '(nil :instance :class :default))
+                                    &optional kind)
+  (unless (member kind '(nil :instance :class))
     (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 (svref ,pv ,pv-offset)))
-            (typecase ,index
-              ,@(when (or (null kind) (eq kind :instance))
-                  `((fixnum (not (and ,slots
-                                      (eq (clos-slots-ref ,slots ,index)
-                                          +slot-unbound+))))))
-              ,@(when (or (null kind) (eq kind :class))
-                  `((cons (not (eq (cdr ,index) +slot-unbound+)))))
-              (t ,default)))))))
+  (let* ((index (gensym)))
+    `(locally (declare #.*optimize-speed*)
+       (let ((,index (svref ,pv ,pv-offset)))
+         (typecase ,index
+           ,@(when (or (null kind) (eq kind :instance))
+                   `((fixnum (not (and ,slots
+                                       (eq (clos-slots-ref ,slots ,index)
+                                           +slot-unbound+))))))
+           ,@(when (or (null kind) (eq kind :class))
+                   `((cons (not (eq (cdr ,index) +slot-unbound+)))))
+           (t ,default))))))
 
 (defmacro instance-boundp (pv-offset parameter position slot-name class)
   (if (skip-fast-slot-access-p class slot-name 'boundp)
@@ -586,7 +458,9 @@
       (dolist (slot-entry (cdr parameter-entry))
         (incf pv-offset)
         (dolist (form (cdr slot-entry))
-          (setf (cadr form) pv-offset))))
+          (setf (cadr form) pv-offset))
+        ;; Count one more for the slot we use for typecheckfun.
+        (incf pv-offset)))
     sorted-slots))
 
 (defun symbol-pkg-name (sym)
@@ -669,110 +543,54 @@
   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
   ;; symbol-macrolet.
   (if (eq (macroexpand 'pv-env-environment env) 'default)
-      `(locally ,@forms)
+      `(locally (declare (simple-vector .pv.))
+         ,@forms)
       `(let* ((.pv-table. ,pv-table-form)
               (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
         (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
-(defvar *non-var-declarations*
-  ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
-  ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
-  ;; SBCL doesn't have 'em, VALUES should probably be removed from
-  ;; this list.
-  '(values
-    %method-name
-    %method-lambda-list
-    optimize
-    ftype
-    muffle-conditions
-    inline
-    notinline))
-
-(defvar *var-declarations-with-arg*
-  '(%class
-    type))
-
-(defvar *var-declarations-without-arg*
-  '(ignore
-    ignorable special dynamic-extent
-    ;; FIXME: Possibly this entire list and variable could go away.
-    ;; If not, certainly we should remove all these built-in typenames
-    ;; from the list, and replace them with a test for "is it a type
-    ;; name?" (CLTL1 allowed only built-in type names as declarations,
-    ;; but ANSI CL allows any type name as a declaration.)
-    array atom base-char bignum bit bit-vector character compiled-function
-    complex cons double-float extended-char
-    fixnum float function hash-table integer
-    keyword list long-float nil null number package pathname random-state ratio
-    rational readtable sequence short-float signed-byte simple-array
-    simple-bit-vector simple-string simple-vector single-float standard-char
-    stream string symbol t unsigned-byte vector))
-
 (defun split-declarations (body args maybe-reads-params-p)
   (let ((inner-decls nil)
         (outer-decls nil)
         decl)
-    (loop (when (null body) (return nil))
-          (setq decl (car body))
-          (unless (and (consp decl)
-                       (eq (car decl) 'declare))
-            (return nil))
-          (dolist (form (cdr decl))
-            (when (consp form)
-              (let ((declaration-name (car form)))
-                (if (member declaration-name *non-var-declarations*)
-                    (push `(declare ,form) outer-decls)
-                    (let ((arg-p
-                           (member declaration-name
-                                   *var-declarations-with-arg*))
-                          (non-arg-p
-                           (member declaration-name
-                                   *var-declarations-without-arg*))
-                          (dname (list (pop form)))
-                          (inners nil) (outers nil))
-                      (unless (or arg-p non-arg-p)
-                        ;; FIXME: This warning, and perhaps the
-                        ;; various *VAR-DECLARATIONS-FOO* and/or
-                        ;; *NON-VAR-DECLARATIONS* variables,
-                        ;; could probably go away now that we're not
-                        ;; trying to be portable between different
-                        ;; CLTL1 hosts the way PCL was. (Note that to
-                        ;; do this right, we need to be able to handle
-                        ;; user-defined (DECLAIM (DECLARATION FOO))
-                        ;; stuff.)
-                        (warn "The declaration ~S is not understood by ~S.~@
-                               Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
-                        (Assuming it is a variable declaration without argument)."
-                              declaration-name 'split-declarations
-                              declaration-name
-                              '*non-var-declarations*
-                              '*var-declarations-with-arg*
-                              '*var-declarations-without-arg*)
-                        (push declaration-name *var-declarations-without-arg*))
-                      (when arg-p
-                        (setq dname (append dname (list (pop form)))))
-                      (case (car dname)
-                        (%class (push `(declare (,@dname ,@form)) inner-decls))
-                        (t
-                         (dolist (var form)
-                           (if (member var args)
-                               ;; Quietly remove IGNORE declarations
-                               ;; on args when a next-method is
-                               ;; involved, to prevent compiler
-                               ;; warnings about ignored args being
-                               ;; read.
-                               (unless (and maybe-reads-params-p
-                                            (eq (car dname) 'ignore))
-                                 (push var outers))
-                               (push var inners)))
-                         (when outers
-                           (push `(declare (,@dname ,@outers)) outer-decls))
-                         (when inners
-                           (push
-                            `(declare (,@dname ,@inners))
-                            inner-decls)))))))))
-          (setq body (cdr body)))
+    (loop
+      (when (null body)
+        (return nil))
+      (setq decl (car body))
+      (unless (and (consp decl) (eq (car decl) 'declare))
+        (return nil))
+      (dolist (form (cdr decl))
+        (when (consp form)
+          (let* ((name (car form)))
+            (cond ((eq '%class name)
+                   (push `(declare ,form) inner-decls))
+                  ((or (member name '(ignore ignorable special dynamic-extent type))
+                       (info :type :kind name))
+                   (let* ((inners nil)
+                          (outers nil)
+                          (tail (cdr form))
+                          (head (if (eq 'type name)
+                                    (list name (pop tail))
+                                    (list name))))
+                     (dolist (var tail)
+                       (if (member var args :test #'eq)
+                           ;; Quietly remove IGNORE declarations on
+                           ;; 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)
+                             (push var outers))
+                           (push var inners)))
+                     (when outers
+                       (push `(declare (,@head ,@outers)) outer-decls))
+                     (when inners
+                       (push `(declare (,@head ,@inners)) inner-decls))))
+                  (t
+                   ;; All other declarations are not variable declarations,
+                   ;; so they become outer declarations.
+                   (push `(declare ,form) outer-decls))))))
+      (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
 ;;; Pull a name out of the %METHOD-NAME declaration in the function
@@ -834,7 +652,7 @@
   ;; 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)
+        do (unless (member x lambda-list-keywords :test #'eq)
              (if (consp x)
                  (let ((name (car x)))
                    (if (consp name)
@@ -979,25 +797,18 @@
   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
 
 (defun pv-wrappers-from-pv-args (&rest args)
-  (let (wrappers)
-    (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
-      (let ((wrapper (wrapper-of arg)))
-        (push (if (invalid-wrapper-p wrapper)
-                  (check-wrapper-validity wrapper)
-                  wrapper)
-              wrappers)))))
+  (loop for arg in args
+        collect (valid-wrapper-of arg)))
 
 (defun pv-wrappers-from-all-args (pv-table args)
-  (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
+  (loop for snl in (pv-table-slot-name-lists pv-table)
+        and arg in args
         when snl
-          collect (wrapper-of arg) into wrappers
-        finally (return (if (cdr wrappers) wrappers (car wrappers)))))
+        collect (valid-wrapper-of arg)))
 
 ;;; Return the subset of WRAPPERS which is used in the cache
 ;;; of PV-TABLE.
 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
         when snl
-          collect w into result
-        finally (return (if (cdr result) result (car result)))))
-
+        collect w))