src/pcl/vector.lisp

   1 ;;;; permutation vectors
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27
  28 ;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation
  29 ;;;; for optimizing GF calls inside method bodies using a PV approach,
  30 ;;;; inherited from the original PCL. This was never completed, and
  31 ;;;; was removed at that point to make the code easier to understand
  32 ;;;; -- but:
  33 ;;;;
  34 ;;;; FIXME: It would be possible to optimize GF calls inside method
  35 ;;;; bodies using permutation vectors: if all the arguments to the
  36 ;;;; GF are specializers parameters, we can assign a permutation index
  37 ;;;; to each such (GF . ARGS) tuple inside a method body, and use this
  38 ;;;; to cache effective method functions.
  39 \f
  40 (declaim (inline make-pv-table))
  41 (defstruct (pv-table (:predicate pv-tablep)
  42                      (:copier nil))
  43   (cache nil :type (or cache null))
  44   (pv-size 0 :type fixnum)
  45   (slot-name-lists nil :type list))
  46
  47 (defun make-pv-table-type-declaration (var)
  48   `(type pv-table ,var))
  49
  50 ;;; Used for interning parts of SLOT-NAME-LISTS, as part of
  51 ;;; PV-TABLE interning -- just to save space.
  52 (define-load-time-global *slot-name-lists* (make-hash-table :test 'equal))
  53
  54 ;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
  55 ;;; used.
  56 (define-load-time-global *pv-tables* (make-hash-table :test 'equal))
  57
  58 ;;; ...and one lock to rule them. Lock because for certain (rare)
  59 ;;; cases this lock might be grabbed in the course of method dispatch
  60 ;;; -- and mostly this is already under the *world-lock*
  61 (define-load-time-global *pv-lock*
  62   (sb-thread:make-mutex :name "pv table index lock"))
  63
  64 (defun intern-pv-table (&key slot-name-lists)
  65   (flet ((intern-slot-names (slot-names)
  66            (ensure-gethash slot-names *slot-name-lists* slot-names))
  67          (%intern-pv-table (snl)
  68            (ensure-gethash
  69             snl *pv-tables*
  70             (make-pv-table :slot-name-lists snl
  71                            :pv-size (* 2 (reduce #'+ snl :key #'length))))))
  72     (sb-thread:with-mutex (*pv-lock*)
  73       (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
  74 \f
  75 (defun use-standard-slot-access-p (class slot-name type)
  76   (or (not (eq **boot-state** 'complete))
  77       (and (standard-class-p class)
  78            (let ((slotd (find-slot-definition class slot-name)))
  79              (and slotd
  80                   (slot-accessor-std-p slotd type))))))
  81
  82 (defun slot-missing-info (class slot-name)
  83   (make-slot-info
  84    :reader (lambda (object)
  85              (values (slot-missing class object slot-name 'slot-value)))
  86    :boundp (lambda (object)
  87              (and (slot-missing class object slot-name 'slot-boundp) t))
  88    :writer (lambda (new-value object)
  89              (slot-missing class object slot-name 'setf new-value)
  90              new-value)))
  91
  92 (defun compute-pv (slot-name-lists wrappers)
  93   (let ((wrappers (ensure-list wrappers)))
  94     (collect ((pv))
  95       (dolist (slot-names slot-name-lists)
  96         (when slot-names
  97           (let* ((wrapper (pop wrappers))
  98                  (std-p (layout-for-std-class-p wrapper))
  99                  (class (wrapper-class* wrapper)))
 100             (dolist (slot-name slot-names)
 101               (destructuring-bind (location . info)
 102                   (or (find-slot-cell wrapper slot-name)
 103                       (cons nil (slot-missing-info class slot-name)))
 104                 (unless info
 105                   (bug "No SLOT-INFO for ~S in ~S" slot-name class))
 106                 (pv (when (and std-p (use-standard-slot-access-p class slot-name 'all))
 107                       location))
 108                 (pv info))))))
 109       (coerce (pv) 'vector))))
 110
 111 (defun pv-table-lookup (pv-table pv-wrappers)
 112   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
 113          (cache (or (pv-table-cache pv-table)
 114                     (setf (pv-table-cache pv-table)
 115                           (make-cache :key-count (- (length slot-name-lists)
 116                                                     (count nil slot-name-lists))
 117                                       :value t
 118                                       :size 2)))))
 119     (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
 120       (if hitp
 121           value
 122           (let* ((pv (compute-pv slot-name-lists pv-wrappers))
 123                  (new-cache (fill-cache cache pv-wrappers pv)))
 124             ;; This is safe: if another thread races us here the loser just
 125             ;; misses the next time as well.
 126             (unless (eq new-cache cache)
 127               (setf (pv-table-cache pv-table) new-cache))
 128             pv)))))
 129
 130 (defun make-pv-type-declaration (var)
 131   `(type simple-vector ,var))
 132 \f
 133 ;;; Sometimes we want to finalize if we can, but it's OK if
 134 ;;; we can't.
 135 (defun try-finalize-inheritance (class)
 136   (unless (typep class 'forward-referenced-class)
 137     (when (every (lambda (super)
 138                    (or (eq super class)
 139                        (class-finalized-p super)
 140                        (try-finalize-inheritance super)))
 141                  (class-direct-superclasses class))
 142       (finalize-inheritance class)
 143       t)))
 144
 145 (declaim (ftype (sfunction (class) class) ensure-class-finalized)
 146          (maybe-inline ensure-class-finalized))
 147 (defun ensure-class-finalized (class)
 148   (unless (class-finalized-p class)
 149     (finalize-inheritance class))
 150   class)
 151
 152 (defun can-optimize-access (form required-parameters env)
 153   (destructuring-bind (op var-form slot-name-form &optional new-value) form
 154     (let ((type (ecase op
 155                   (slot-value 'reader)
 156                   (set-slot-value 'writer)
 157                   (slot-boundp 'boundp)))
 158           (var (extract-the var-form))
 159           (slot-name (constant-form-value slot-name-form env)))
 160       (when (and (symbolp var) (not (var-special-p var env)))
 161         (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
 162                (parameter-or-nil (car (memq (or rebound? var)
 163                                             required-parameters))))
 164           (when parameter-or-nil
 165             (let* ((class-name (caddr (var-declaration '%class
 166                                                        parameter-or-nil
 167                                                        env)))
 168                    (class (find-class class-name nil)))
 169               (cond ((or (not (eq **boot-state** 'complete))
 170                          (forward-referenced-class-p class))
 171                      (setf class nil))
 172                     ((and class (not (class-finalized-p class)))
 173                      (unless (try-finalize-inheritance class)
 174                        (when (boundp 'sb-c:*lexenv*)
 175                          (sb-c:compiler-notify
 176                           "~@<Cannot optimize slot access, inheritance of ~S is not ~
 177                            yet finalizable due to forward-referenced superclasses:~
 178                            ~%  ~S~:@>"
 179                           class form))
 180                        (setf class nil))))
 181               (when (and class-name (not (eq class-name t)))
 182                 (when (not (and class
 183                                 (memq *the-class-structure-object*
 184                                       (class-precedence-list class))))
 185                   (aver type)
 186                   (values (cons parameter-or-nil (or class class-name))
 187                           slot-name
 188                           new-value))))))))))
 189
 190 ;;; Check whether the binding of the named variable is modified in the
 191 ;;; method body.
 192 (defun parameter-modified-p (parameter-name env)
 193   (let ((modified-variables (%macroexpand '%parameter-binding-modified env)))
 194     (memq parameter-name modified-variables)))
 195
 196 (defun optimize-slot-value (form slots required-parameters env)
 197   (multiple-value-bind (sparameter slot-name)
 198       (can-optimize-access form required-parameters env)
 199     (if sparameter
 200         (let ((optimized-form
 201                (optimize-instance-access slots :read sparameter
 202                                          slot-name nil)))
 203           ;; We don't return the optimized form directly, since there's
 204           ;; still a chance that we'll find out later on that the
 205           ;; optimization should not have been done, for example due to
 206           ;; the walker encountering a SETQ on SPARAMETER later on in
 207           ;; the body [ see for example clos.impure.lisp test with :name
 208           ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
 209           ;; the decision until the compiler macroexpands
 210           ;; OPTIMIZED-SLOT-VALUE.
 211           ;;
 212           ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
 213           ;; this point (instead of when expanding
 214           ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
 215           ;; SLOTS. If that mutation isn't done during the walking,
 216           ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
 217           ;; form around the body, and compilation will fail.  -- JES,
 218           ;; 2006-09-18
 219           `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
 220         `(accessor-slot-value ,@(cdr form)))))
 221
 222 (defmacro optimized-slot-value (form parameter-name optimized-form
 223                                 &environment env)
 224   ;; Either use OPTIMIZED-FORM or fall back to the safe
 225   ;; ACCESSOR-SLOT-VALUE.
 226   (if (parameter-modified-p parameter-name env)
 227       `(accessor-slot-value ,@(cdr form))
 228       optimized-form))
 229
 230 (defun optimize-set-slot-value (form slots required-parameters env)
 231   (multiple-value-bind (sparameter slot-name new-value)
 232       (can-optimize-access form required-parameters env)
 233     (if sparameter
 234         (let ((optimized-form
 235                (optimize-instance-access slots :write sparameter
 236                                          slot-name new-value (safe-code-p env))))
 237              ;; See OPTIMIZE-SLOT-VALUE
 238              `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
 239            `(accessor-set-slot-value ,@(cdr form)))))
 240
 241 (defmacro optimized-set-slot-value (form parameter-name optimized-form
 242                                     &environment env)
 243   (cond ((parameter-modified-p parameter-name env)
 244          ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking,
 245          ;; so we need to use SAFE-SET-SLOT-VALUE.
 246          (if (safe-code-p env)
 247              `(safe-set-slot-value ,@(cdr form)))
 248              `(accessor-set-slot-value ,@(cdr form)))
 249         (t
 250          optimized-form)))
 251
 252 (defun optimize-slot-boundp (form slots required-parameters env)
 253   (multiple-value-bind (sparameter slot-name)
 254       (can-optimize-access form required-parameters env)
 255     (if sparameter
 256         (let ((optimized-form
 257                (optimize-instance-access slots :boundp sparameter
 258                                          slot-name nil)))
 259           ;; See OPTIMIZE-SLOT-VALUE
 260           `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
 261         `(accessor-slot-boundp ,@(cdr form)))))
 262
 263 (defmacro optimized-slot-boundp (form parameter-name optimized-form
 264                                  &environment env)
 265   (if (parameter-modified-p parameter-name env)
 266       `(accessor-slot-boundp ,@(cdr form))
 267       optimized-form))
 268
 269 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
 270 ;;; of a required parameter to the function. The alist is in order, so
 271 ;;; the position of an entry in the alist corresponds to the
 272 ;;; argument's position in the lambda list.
 273 (defun optimize-instance-access (slots read/write sparameter slot-name
 274                                  new-value &optional safep)
 275   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
 276         (parameter (if (consp sparameter) (car sparameter) sparameter)))
 277     (if (and (eq **boot-state** 'complete)
 278              (classp class)
 279              (memq *the-class-structure-object* (class-precedence-list class)))
 280         (let ((slotd (find-slot-definition class slot-name)))
 281           (ecase read/write
 282             (:read
 283              `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
 284             (:write
 285              `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
 286                      ,parameter)
 287                     ,new-value))
 288             (:boundp
 289              t)))
 290         (let* ((parameter-entry (assq parameter slots))
 291                (slot-entry      (assq slot-name (cdr parameter-entry)))
 292                (position (posq parameter-entry slots))
 293                (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
 294           (unless parameter-entry
 295             (bug "slot optimization bewilderment: O-I-A"))
 296           (unless slot-entry
 297             (setq slot-entry (list slot-name))
 298             (push slot-entry (cdr parameter-entry)))
 299           (push pv-offset-form (cdr slot-entry))
 300           (ecase read/write
 301             (:read
 302              `(instance-read ,pv-offset-form ,parameter ,position
 303                              ',slot-name ',class))
 304             (:write
 305              `(let ((.new-value. ,new-value))
 306                 (instance-write ,pv-offset-form ,parameter ,position
 307                                 ',slot-name ',class .new-value. ,safep)))
 308             (:boundp
 309              `(instance-boundp ,pv-offset-form ,parameter ,position
 310                                ',slot-name ',class)))))))
 311
 312 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
 313 (defmacro pv-offset (arg) arg)
 314 (define-walker-template instance-accessor-parameter)
 315 (defmacro instance-accessor-parameter (x) x)
 316
 317 ;;; It is safe for these two functions to be wrong. They just try to
 318 ;;; guess what the most likely case will be.
 319 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
 320   (let ((class (and (constantp class-form) (constant-form-value class-form)))
 321         (slot-name (and (constantp slot-name-form)
 322                         (constant-form-value slot-name-form))))
 323     (and (eq **boot-state** 'complete)
 324          (standard-class-p class)
 325          (not (eq class *the-class-t*)) ; shouldn't happen, though.
 326          (let ((slotd (find-slot-definition class slot-name)))
 327            (and slotd (eq :class (slot-definition-allocation slotd)))))))
 328
 329 (defun constant-value-or-nil (form)
 330   (and (constantp form) (constant-form-value form)))
 331
 332 (defun slot-access-strategy (class slot-name type &optional conservative)
 333   ;; CONSERVATIVE means we should assume custom access pattern even if
 334   ;; there are no custom accessors defined if the metaclass is non-standard.
 335   ;;
 336   ;; This is needed because DEFCLASS generates accessor methods before possible
 337   ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take
 338   ;; the slow path unless we make the conservative assumption here.
 339   (if (eq **boot-state** 'complete)
 340       (let (slotd)
 341         (cond ((or
 342                 ;; Conditions, structures, and classes for which FIND-CLASS
 343                 ;; doesn't return them yet.
 344                 ;; FIXME: surely we can get faster accesses for structures?
 345                 (not (standard-class-p class))
 346                 ;; Should not happen... (FIXME: assert instead?)
 347                 (eq class *the-class-t*)
 348                 (not (class-finalized-p class))
 349                 ;; Strangeness...
 350                 (not (setf slotd (find-slot-definition class slot-name))))
 351                :accessor)
 352               ((and (slot-accessor-std-p slotd type)
 353                     (or (not conservative) (eq *the-class-standard-class* (class-of class))))
 354                ;; The best case.
 355                :standard)
 356               (t
 357                :custom)))
 358       :standard))
 359
 360 ;;;; SLOT-VALUE
 361
 362 (defmacro instance-read (pv-offset parameter position slot-name class)
 363   (ecase (slot-access-strategy (constant-value-or-nil class)
 364                                (constant-value-or-nil slot-name)
 365                                'reader)
 366     (:standard
 367      `(instance-read-standard
 368        .pv. ,(slot-vector-symbol position)
 369        ,pv-offset (accessor-slot-value ,parameter ,slot-name)
 370        ,(if (generate-fast-class-slot-access-p class slot-name)
 371             :class :instance)))
 372     (:custom
 373      `(instance-read-custom .pv. ,pv-offset ,parameter))
 374     (:accessor
 375      `(accessor-slot-value ,parameter ,slot-name))))
 376
 377 (defmacro instance-read-standard (pv slots pv-offset default &optional kind)
 378   (unless (member kind '(nil :instance :class))
 379     (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind))
 380   (let* ((index (gensym))
 381          (value index))
 382     `(locally (declare #.*optimize-speed*)
 383        (let ((,index (svref ,pv ,pv-offset))
 384              (,slots (truly-the simple-vector ,slots)))
 385          (setq ,value (typecase ,index
 386                         ;; FIXME: the line marked by KLUDGE below (and
 387                         ;; the analogous spot in
 388                         ;; INSTANCE-WRITE-STANDARD) is there purely to
 389                         ;; suppress a type mismatch warning that
 390                         ;; propagates through to user code.
 391                         ;; Presumably SLOTS at this point can never
 392                         ;; actually be NIL, but the compiler seems to
 393                         ;; think it could, so we put this here to shut
 394                         ;; it up.  (see also mail Rudi Schlatte
 395                         ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30
 396                         ,@(when (or (null kind) (eq kind :instance))
 397                                 `((fixnum
 398                                    (clos-slots-ref ,slots ,index))))
 399                         ,@(when (or (null kind) (eq kind :class))
 400                                 `((cons (cdr ,index))))
 401                         (t
 402                          +slot-unbound+)))
 403          (if (unbound-marker-p ,value)
 404              ,default
 405              ,value)))))
 406
 407 (defmacro instance-read-custom (pv pv-offset parameter)
 408   `(locally (declare #.*optimize-speed*)
 409      (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter)))
 410
 411 ;;;; (SETF SLOT-VALUE)
 412
 413 (defmacro instance-write (pv-offset parameter position slot-name class new-value
 414                           &optional check-type-p)
 415   (ecase (slot-access-strategy (constant-value-or-nil class)
 416                                (constant-value-or-nil slot-name)
 417                                'writer)
 418     (:standard
 419      `(instance-write-standard
 420        .pv. ,(slot-vector-symbol position)
 421        ,pv-offset ,new-value
 422        ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
 423        ;; is executed (if it is executed).
 424        (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
 425        ,(if (generate-fast-class-slot-access-p class slot-name)
 426             :class :instance)
 427        ,check-type-p))
 428     (:custom
 429      `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value))
 430     (:accessor
 431      (if check-type-p
 432          ;; FIXME: We don't want this here. If it's _possible_ the fast path
 433          ;; is applicable, we want to use it as well.
 434          `(safe-set-slot-value ,parameter ,slot-name ,new-value)
 435          `(accessor-set-slot-value ,parameter ,slot-name ,new-value)))))
 436
 437 (defmacro instance-write-standard (pv slots pv-offset new-value default
 438                                    &optional kind safep)
 439   (unless (member kind '(nil :instance :class))
 440     (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind))
 441   (let* ((index (gensym))
 442          (new-value-form
 443           (if safep
 444               `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset)))))
 445                  (declare (type (or function null) .typecheckfun.))
 446                  (if .typecheckfun.
 447                      (funcall .typecheckfun. ,new-value)
 448                      ,new-value))
 449               new-value)))
 450     `(locally (declare #.*optimize-speed*)
 451        (let ((.good-new-value. ,new-value-form)
 452              (,index (svref ,pv ,pv-offset)))
 453          (typecase ,index
 454            ,@(when (or (null kind) (eq kind :instance))
 455                    `((fixnum (and ,slots
 456                                   (setf (clos-slots-ref ,slots ,index)
 457                                         .good-new-value.)))))
 458            ,@(when (or (null kind) (eq kind :class))
 459                    `((cons (setf (cdr ,index) .good-new-value.))))
 460            (t ,default))))))
 461
 462 (defmacro instance-write-custom (pv pv-offset parameter new-value)
 463   `(locally (declare #.*optimize-speed*)
 464      (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter)))
 465
 466 ;;;; SLOT-BOUNDP
 467
 468 (defmacro instance-boundp (pv-offset parameter position slot-name class)
 469   (ecase (slot-access-strategy (constant-value-or-nil class)
 470                                (constant-value-or-nil slot-name)
 471                                'boundp)
 472     (:standard
 473      `(instance-boundp-standard
 474        .pv. ,(slot-vector-symbol position)
 475        ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
 476        ,(if (generate-fast-class-slot-access-p class slot-name)
 477             :class :instance)))
 478     (:custom
 479      `(instance-boundp-custom .pv. ,pv-offset ,parameter))
 480     (:accessor
 481      `(accessor-slot-boundp ,parameter ,slot-name))))
 482
 483 (defmacro instance-boundp-standard (pv slots pv-offset default
 484                                     &optional kind)
 485   (unless (member kind '(nil :instance :class))
 486     (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind))
 487   (let* ((index (gensym)))
 488     `(locally (declare #.*optimize-speed*)
 489        (let ((,index (svref ,pv ,pv-offset)))
 490          (typecase ,index
 491            ,@(when (or (null kind) (eq kind :instance))
 492                    `((fixnum (not (and ,slots
 493                                        (unbound-marker-p
 494                                         (clos-slots-ref ,slots ,index)))))))
 495            ,@(when (or (null kind) (eq kind :class))
 496                    `((cons (not (unbound-marker-p (cdr ,index))))))
 497            (t ,default))))))
 498
 499 (defmacro instance-boundp-custom (pv pv-offset parameter)
 500   `(locally (declare #.*optimize-speed*)
 501      (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter)))
 502
 503 ;;; This magic function has quite a job to do indeed.
 504 ;;;
 505 ;;; The careful reader will recall that <slots> contains all of the
 506 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
 507 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
 508 ;;;
 509 ;;; At the time these calls were produced, the first argument was
 510 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
 511 ;;; convert those pv-offset arguments into the actual number that is
 512 ;;; the correct offset into the pv.
 513 ;;;
 514 ;;; But first, oh but first, we sort <slots> a bit so that for each
 515 ;;; argument we have the slots in an order defined by
 516 ;;; SYMBOL-OR-CONS-LESSP. This canonicalizes the PV-TABLEs a bit and
 517 ;;; will hopefully lead to having fewer PVs floating around. Even if
 518 ;;; the gain is only modest, it costs nothing.
 519 (defun slot-name-lists-from-slots (slots)
 520   (mapcar (lambda (parameter-entry)
 521             (when (cdr parameter-entry)
 522               (mapcar #'car (cdr parameter-entry))))
 523           (mutate-slots slots)))
 524
 525 (defun mutate-slots (slots)
 526   (let ((sorted-slots (sort-slots slots))
 527         (pv-offset -1))
 528     (dolist (parameter-entry sorted-slots)
 529       (dolist (slot-entry (cdr parameter-entry))
 530         (incf pv-offset)
 531         (dolist (form (cdr slot-entry))
 532           (setf (cadr form) pv-offset))
 533         ;; Count one more for the slot we use for SLOT-INFO.
 534         (incf pv-offset)))
 535     sorted-slots))
 536
 537 (defun symbol-or-cons-lessp (a b)
 538   (etypecase a
 539     (symbol (etypecase b
 540               (symbol (< (symbol-hash a) (symbol-hash b)))
 541               (cons t)))
 542     (cons   (etypecase b
 543               (symbol nil)
 544               (cons (if (eq (car a) (car b))
 545                         (symbol-or-cons-lessp (cdr a) (cdr b))
 546                         (symbol-or-cons-lessp (car a) (car b))))))))
 547
 548 (defun sort-slots (slots)
 549   (mapcar (lambda (parameter-entry)
 550             (destructuring-bind (name . entries) parameter-entry
 551               (cons name (stable-sort entries #'symbol-or-cons-lessp
 552                                       :key #'car))))
 553           slots))
 554
 555 \f
 556 ;;;; This needs to work in terms of metatypes and also needs to work
 557 ;;;; for automatically generated reader and writer functions.
 558 ;;;; Automatically generated reader and writer functions use this
 559 ;;;; stuff too.
 560
 561 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
 562                       &body body)
 563   (let (slot-vars pv-parameters)
 564     (loop for slots in slot-name-lists
 565           for required-parameter in required-parameters
 566           for i from 0
 567           do (when slots
 568                (push required-parameter pv-parameters)
 569                (push (slot-vector-symbol i) slot-vars)))
 570     `(pv-binding1 (,pv-table-form
 571                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
 572        ,@body)))
 573
 574 (defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars)
 575                        &body body)
 576   `(pv-env (,pv-table-form ,pv-parameters)
 577      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
 578                      slot-vars pv-parameters))
 579        (declare (ignorable ,@(mapcar #'identity slot-vars)))
 580        ,@body)))
 581
 582 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
 583 ;;; overridden.
 584 (define-symbol-macro pv-env-environment overridden)
 585
 586 (defmacro pv-env (&environment env
 587                   (pv-table-form pv-parameters)
 588                   &rest forms)
 589   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
 590   ;; symbol-macrolet.
 591   (if (eq (macroexpand 'pv-env-environment env) 'default)
 592       `(locally (declare (simple-vector .pv.))
 593          ,@forms)
 594       `(let* ((.pv-table. ,pv-table-form)
 595               (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
 596         (declare ,(make-pv-type-declaration '.pv.))
 597         ,@forms)))
 598
 599 (defun split-declarations (body args req-args cnm-p parameters-setqd)
 600   (let ((inner-decls nil)
 601         (outer-decls nil)
 602         decl)
 603     (loop
 604       (when (null body)
 605         (return nil))
 606       (setq decl (car body))
 607       (unless (and (consp decl) (eq (car decl) 'declare))
 608         (return nil))
 609       (dolist (form (cdr decl))
 610         (when (consp form)
 611           (let* ((name (car form)))
 612             (cond ((eq '%class name)
 613                    (push `(declare ,form) inner-decls))
 614                   ((or (member name '(ignore ignorable special dynamic-extent type))
 615                        (info :type :kind name))
 616                    (let* ((inners nil)
 617                           (outers nil)
 618                           (tail (cdr form))
 619                           (head (if (eq 'type name)
 620                                     (list name (pop tail))
 621                                     (list name))))
 622                      (dolist (var tail)
 623                        (if (member var args :test #'eq)
 624                            ;; Quietly remove IGNORE declarations on
 625                            ;; args when a next-method is involved, to
 626                            ;; prevent compiler warnings about ignored
 627                            ;; args being read.
 628                            (unless (and (eq 'ignore name)
 629                                         (member var req-args :test #'eq)
 630                                         (or cnm-p (member var parameters-setqd)))
 631                              (push var outers))
 632                            (push var inners)))
 633                      (when outers
 634                        (push `(declare (,@head ,@outers)) outer-decls))
 635                      (when inners
 636                        (push `(declare (,@head ,@inners)) inner-decls))))
 637                   (t
 638                    ;; All other declarations are not variable declarations,
 639                    ;; so they become outer declarations.
 640                    (push `(declare ,form) outer-decls))))))
 641       (setq body (cdr body)))
 642     (values outer-decls inner-decls body)))
 643
 644 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
 645 ;;; declaration (which is a naming style internal to PCL) into an
 646 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
 647 ;;; throughout SBCL, understood by the main compiler); or if there's
 648 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
 649 ;;; lambda expression.
 650 (defun name-method-lambda (method-lambda)
 651   (let ((method-name *method-name*))
 652     (if method-name
 653         `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda))
 654         method-lambda)))
 655
 656 (defun make-method-initargs-form-internal (method-lambda initargs env)
 657   (declare (ignore env))
 658   (let (method-lambda-args
 659         lmf ; becomes body of function
 660         lmf-params)
 661     (if (not (and (= 3 (length method-lambda))
 662                   (= 2 (length (setq method-lambda-args (cadr method-lambda))))
 663                   (consp (setq lmf (third method-lambda)))
 664                   (eq 'simple-lexical-method-functions (car lmf))
 665                   (eq (car method-lambda-args)
 666                       (cadr (setq lmf-params (cadr lmf))))
 667                   (eq (cadr method-lambda-args)
 668                       (caddr lmf-params))))
 669         `(list* :function ,(name-method-lambda method-lambda)
 670                 ',initargs)
 671         (let* ((lambda-list (car lmf-params))
 672                (nreq 0)
 673                (restp nil)
 674                (args nil))
 675           (dolist (arg lambda-list)
 676             (when (member arg '(&optional &rest &key))
 677               (setq restp t)
 678               (return nil))
 679             (when (eq arg '&aux)
 680               (return nil))
 681             (incf nreq)
 682             (push arg args))
 683           (setq args (nreverse args))
 684           (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
 685           (make-method-initargs-form-internal1
 686            initargs (cddr lmf) args lmf-params restp)))))
 687
 688 (defun lambda-list-parameter-names (lambda-list)
 689   ;; Given a valid lambda list, extract the parameter names.
 690   (loop for x in lambda-list
 691         with res = nil
 692         do (unless (member x lambda-list-keywords :test #'eq)
 693              (if (consp x)
 694                  (let ((name (car x)))
 695                    (if (consp name)
 696                        ;; ... ((:BAR FOO) 1)
 697                        (push (second name) res)
 698                        ;; ... (FOO 1)
 699                        (push name res))
 700                    ;; ... (... 1 FOO-P)
 701                    (let ((name-p (cddr x)))
 702                      (when name-p
 703                        (push (car name-p) res))))
 704                  ;; ... FOO
 705                  (push x res)))
 706         finally (return res)))
 707
 708 (defun make-method-initargs-form-internal1
 709     (initargs body req-args lmf-params restp)
 710   (let* (;; The lambda-list of the method, minus specifiers
 711          (lambda-list (car lmf-params))
 712          ;; Names of the parameters that will be in the outermost lambda-list
 713          ;; (and whose bound declarations thus need to be in OUTER-DECLS).
 714          (outer-parameters req-args)
 715          ;; The lambda-list used by BIND-ARGS
 716          (bind-list lambda-list)
 717          (parameters-setqd (getf (cdr lmf-params) :parameters-setqd))
 718          (auxp (member '&aux bind-list))
 719          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
 720     ;; Try to use the normal function call machinery instead of BIND-ARGS
 721     ;; binding the arguments, unless:
 722     (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
 723                 ;; in any case.
 724                 (and (not restp) (not auxp))
 725                 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
 726                 ;; list of all non-required arguments.
 727                 call-next-method-p)
 728       (setf ;; We don't want a binding for .REST-ARG.
 729             restp nil
 730             ;; Get all the parameters for declaration parsing
 731             outer-parameters (lambda-list-parameter-names lambda-list)
 732             ;; Ensure that BIND-ARGS won't do anything (since
 733             ;; BIND-LIST won't contain any non-required parameters,
 734             ;; and REQ-ARGS will be of an equal length). We still want
 735             ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
 736             ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
 737             ;; of rebinding SETQd required arguments around the method
 738             ;; body.
 739             bind-list req-args))
 740     (multiple-value-bind (outer-decls inner-decls body-sans-decls)
 741         (split-declarations
 742          body outer-parameters req-args call-next-method-p parameters-setqd)
 743       (let* ((rest-arg (when restp
 744                          '.rest-arg.))
 745              (fmf-lambda-list (if rest-arg
 746                                   (append req-args (list '&rest rest-arg))
 747                                   (if call-next-method-p
 748                                       req-args
 749                                       lambda-list))))
 750         `(list*
 751           :function
 752           (let* ((fmf (,(if *method-name* 'named-lambda 'lambda)
 753                         ,@(when *method-name*
 754                                 ;; function name
 755                                 (list `(fast-method ,@*method-name*)))
 756                         ;; The lambda-list of the FMF
 757                         (.pv. .next-method-call. ,@fmf-lambda-list)
 758                         ;; body of the function
 759                         (declare (ignorable .pv. .next-method-call.)
 760                                  (disable-package-locks pv-env-environment))
 761                         ,@outer-decls
 762                         (symbol-macrolet ((pv-env-environment default))
 763                           (fast-lexical-method-functions
 764                               (,bind-list .next-method-call. ,req-args ,rest-arg
 765                                 ,@(cdddr lmf-params))
 766                             ,@inner-decls
 767                             ,@body-sans-decls))))
 768                  (mf (%make-method-function fmf)))
 769             (set-funcallable-instance-function
 770              mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
 771             mf)
 772           ',initargs)))))
 773
 774 ;;; Use arrays and hash tables and the fngen stuff to make this much
 775 ;;; better. It doesn't really matter, though, because a function
 776 ;;; returned by this will get called only when the user explicitly
 777 ;;; funcalls a result of method-function. BUT, this is needed to make
 778 ;;; early methods work.
 779 (defun method-function-from-fast-function (fmf plist)
 780   (declare (type function fmf))
 781   (let* ((method-function nil)
 782          (snl (getf plist :slot-name-lists))
 783          (pv-table (when snl
 784                      (intern-pv-table :slot-name-lists snl))))
 785     (setq method-function
 786           (lambda (method-args next-methods)
 787             (let* ((pv (when pv-table
 788                          (get-pv method-args pv-table)))
 789                    (nm (car next-methods))
 790                    (nms (cdr next-methods))
 791                    (nmc (when nm
 792                           (make-method-call
 793                            :function (if (std-instance-p nm)
 794                                          (method-function nm)
 795                                          nm)
 796                            :call-method-args (list nms)))))
 797               (apply fmf pv nmc method-args))))
 798     ;; FIXME: this looks dangerous.
 799     (let* ((fname (%fun-name fmf)))
 800       (when (and fname (eq (car fname) 'fast-method))
 801         (set-fun-name method-function (cons 'slow-method (cdr fname)))))
 802     method-function))
 803
 804 ;;; this is similar to the above, only not quite.  Only called when
 805 ;;; the MOP is heavily involved.  Not quite parallel to
 806 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
 807 ;;; over the actual PV-CELL in this case.
 808 (defun method-function-from-fast-method-call (fmc)
 809   (let* ((fmf (fast-method-call-function fmc))
 810          (pv (fast-method-call-pv fmc)))
 811     (lambda (method-args next-methods)
 812       (let* ((nm (car next-methods))
 813              (nms (cdr next-methods))
 814              (nmc (when nm
 815                     (make-method-call
 816                      :function (if (std-instance-p nm)
 817                                    (method-function nm)
 818                                    nm)
 819                      :call-method-args (list nms)))))
 820         (apply fmf pv nmc method-args)))))
 821
 822 (defun get-pv (method-args pv-table)
 823   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
 824     (when pv-wrappers
 825       (pv-table-lookup pv-table pv-wrappers))))
 826
 827 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
 828   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
 829
 830 (defun pv-wrappers-from-pv-args (&rest args)
 831   (mapcar #'valid-wrapper-of args))
 832
 833 (defun pv-wrappers-from-all-args (pv-table args)
 834   (loop for snl in (pv-table-slot-name-lists pv-table)
 835         and arg in args
 836         when snl
 837         collect (valid-wrapper-of arg)))
 838
 839 ;;; Return the subset of WRAPPERS which is used in the cache
 840 ;;; of PV-TABLE.
 841 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
 842   (loop for snl in (pv-table-slot-name-lists pv-table)
 843         and w in wrappers
 844         when snl
 845         collect w))