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