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