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