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