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 \f
  28 (defmacro instance-slot-index (wrapper slot-name)
  29   `(let ((pos 0))
  30      (declare (fixnum pos))
  31      (block loop
  32        (dolist (sn (wrapper-instance-slots-layout ,wrapper))
  33          (when (eq ,slot-name sn) (return-from loop pos))
  34          (incf pos)))))
  35 \f
  36 (defun pv-cache-limit-fn (nlines)
  37   (default-limit-fn nlines))
  38
  39 (defstruct (pv-table (:predicate pv-tablep)
  40                      (:constructor make-pv-table-internal
  41                                    (slot-name-lists call-list))
  42                      (:copier nil))
  43   (cache nil :type (or cache null))
  44   (pv-size 0 :type fixnum)
  45   (slot-name-lists nil :type list)
  46   (call-list nil :type list))
  47
  48 #-sb-fluid (declaim (sb-ext:freeze-type pv-table))
  49
  50 ;;; FIXME: The comment below seem to indicate that this was intended
  51 ;;; to be actually used, however, it isn't anymore, and was commented
  52 ;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
  53 ;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
  54 ;;;
  55 ;;;   help new slot-value-using-class methods affect fast iv access
  56 ;;;
  57 ;;;  (defvar *all-pv-table-list* nil)
  58
  59 (declaim (inline make-pv-table))
  60 (defun make-pv-table (&key slot-name-lists call-list)
  61   (make-pv-table-internal slot-name-lists call-list))
  62
  63 (defun make-pv-table-type-declaration (var)
  64   `(type pv-table ,var))
  65
  66 (defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
  67 (defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
  68
  69 ;;; Entries in this are lists of (table . pv-offset-list).
  70 (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
  71
  72 (defun intern-pv-table (&key slot-name-lists call-list)
  73   (let ((new-p nil))
  74     (flet ((inner (x)
  75              (or (gethash x *slot-name-lists-inner*)
  76                  (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
  77            (outer (x)
  78              (or (gethash x *slot-name-lists-outer*)
  79                  (setf (gethash x *slot-name-lists-outer*)
  80                        (let ((snl (copy-list (cdr x)))
  81                              (cl (car x)))
  82                          (setq new-p t)
  83                          (make-pv-table :slot-name-lists snl
  84                                         :call-list cl))))))
  85       (let ((pv-table
  86              (outer (mapcar #'inner (cons call-list slot-name-lists)))))
  87         (when new-p
  88           (let ((pv-index 0))
  89             (dolist (slot-name-list slot-name-lists)
  90               (dolist (slot-name (cdr slot-name-list))
  91                 (note-pv-table-reference slot-name pv-index pv-table)
  92                 (incf pv-index)))
  93             (dolist (gf-call call-list)
  94               (note-pv-table-reference gf-call pv-index pv-table)
  95               (incf pv-index))
  96             (setf (pv-table-pv-size pv-table) pv-index)))
  97         pv-table))))
  98
  99 (defun note-pv-table-reference (ref pv-offset pv-table)
 100   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
 101     (when (listp entry)
 102       (let ((table-entry (assq pv-table entry)))
 103         (when (and (null table-entry)
 104                    (> (length entry) 8))
 105           (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
 106             (dolist (table-entry entry)
 107               (setf (gethash (car table-entry) new-table-table)
 108                     (cdr table-entry)))
 109             (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
 110         (when (listp entry)
 111           (if (null table-entry)
 112               (let ((new (cons pv-table pv-offset)))
 113                 (if (consp entry)
 114                     (push new (cdr entry))
 115                     (setf (gethash ref *pv-key-to-pv-table-table*)
 116                           (list new))))
 117               (push pv-offset (cdr table-entry)))
 118           (return-from note-pv-table-reference nil))))
 119     (let ((list (gethash pv-table entry)))
 120       (if (consp list)
 121           (push pv-offset (cdr list))
 122           (setf (gethash pv-table entry) (list pv-offset)))))
 123   nil)
 124
 125 (defun map-pv-table-references-of (ref function)
 126   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
 127     (if (listp entry)
 128         (dolist (table+pv-offset-list entry)
 129           (funcall function
 130                    (car table+pv-offset-list)
 131                    (cdr table+pv-offset-list)))
 132         (maphash function entry)))
 133   ref)
 134 \f
 135 (defun optimize-slot-value-by-class-p (class slot-name type)
 136   (or (not (eq *boot-state* 'complete))
 137       (let ((slotd (find-slot-definition class slot-name)))
 138         (and slotd
 139              (slot-accessor-std-p slotd type)))))
 140
 141 (defun compute-pv-slot (slot-name wrapper class class-slots)
 142   (if (symbolp slot-name)
 143       (when (optimize-slot-value-by-class-p class slot-name 'all)
 144         (or (instance-slot-index wrapper slot-name)
 145             (assq slot-name class-slots)))
 146       (when (consp slot-name)
 147         (case (first slot-name)
 148           ((reader writer)
 149            (when (eq *boot-state* 'complete)
 150              (let ((gf (gdefinition (second slot-name))))
 151                (when (generic-function-p gf)
 152                  (accessor-values1 gf (first slot-name) class)))))
 153           (t (bug "Don't know how to deal with ~S in ~S"
 154                   slot-name 'compute-pv-slots))))))
 155
 156 (defun compute-pv (slot-name-lists wrappers)
 157   (unless (listp wrappers)
 158     (setq wrappers (list wrappers)))
 159   (let (elements)
 160     (dolist (slot-names slot-name-lists
 161              (make-permutation-vector (nreverse elements)))
 162       (when slot-names
 163         (let* ((wrapper (pop wrappers))
 164                (std-p (typep wrapper 'wrapper))
 165                (class (wrapper-class* wrapper))
 166                (class-slots (and std-p (wrapper-class-slots wrapper))))
 167           (dolist (slot-name (cdr slot-names))
 168             (push (if std-p
 169                       (compute-pv-slot slot-name wrapper class class-slots)
 170                       nil)
 171                   elements)))))))
 172
 173 (defun compute-calls (call-list wrappers)
 174   (declare (ignore call-list wrappers))
 175   #||
 176   (map 'vector
 177        (lambda (call)
 178          (compute-emf-from-wrappers call wrappers))
 179        call-list)
 180   ||#
 181   '#())
 182
 183 #|| ; Need to finish this, then write the maintenance functions.
 184 (defun compute-emf-from-wrappers (call wrappers)
 185   (when call
 186     (destructuring-bind (gf-name nreq restp arg-info) call
 187       (if (eq gf-name 'make-instance)
 188           (error "should not get here") ; there is another mechanism for this.
 189           (lambda (&rest args)
 190             (if (not (eq *boot-state* 'complete))
 191                 (apply (gdefinition gf-name) args)
 192                 (let* ((gf (gdefinition gf-name))
 193                        (arg-info (arg-info-reader gf))
 194                        (classes '?)
 195                        (types '?)
 196                        (emf (cache-miss-values-internal gf arg-info
 197                                                         wrappers classes types
 198                                                         'caching)))
 199                   (update-all-pv-tables call wrappers emf)
 200                   (invoke-emf emf args))))))))
 201 ||#
 202
 203 (defun make-permutation-vector (indexes)
 204   (make-array (length indexes) :initial-contents indexes))
 205
 206 (defun pv-table-lookup (pv-table pv-wrappers)
 207   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
 208          (call-list (pv-table-call-list pv-table))
 209          (cache (or (pv-table-cache pv-table)
 210                     (setf (pv-table-cache pv-table)
 211                           (get-cache (- (length slot-name-lists)
 212                                         (count nil slot-name-lists))
 213                                      t
 214                                      #'pv-cache-limit-fn
 215                                      2)))))
 216     (or (probe-cache cache pv-wrappers)
 217         (let* ((pv (compute-pv slot-name-lists pv-wrappers))
 218                (calls (compute-calls call-list pv-wrappers))
 219                (pv-cell (cons pv calls))
 220                (new-cache (fill-cache cache pv-wrappers pv-cell)))
 221           (unless (eq new-cache cache)
 222             (setf (pv-table-cache pv-table) new-cache))
 223           pv-cell))))
 224
 225 (defun make-pv-type-declaration (var)
 226   `(type simple-vector ,var))
 227
 228 (defmacro pvref (pv index)
 229   `(svref ,pv ,index))
 230
 231 (defmacro copy-pv (pv)
 232   `(copy-seq ,pv))
 233
 234 (defun make-calls-type-declaration (var)
 235   `(type simple-vector ,var))
 236
 237 (defmacro callsref (calls index)
 238   `(svref ,calls ,index))
 239
 240 (defvar *pv-table-cache-update-info* nil)
 241
 242 (defun update-pv-table-cache-info (class)
 243   (let ((slot-names-for-pv-table-update nil)
 244         (new-icui nil))
 245     (dolist (icu *pv-table-cache-update-info*)
 246       (if (eq (car icu) class)
 247           (pushnew (cdr icu) slot-names-for-pv-table-update)
 248           (push icu new-icui)))
 249     (setq *pv-table-cache-update-info* new-icui)
 250     (when slot-names-for-pv-table-update
 251       (update-all-pv-table-caches class slot-names-for-pv-table-update))))
 252
 253 (defun update-all-pv-table-caches (class slot-names)
 254   (let* ((cwrapper (class-wrapper class))
 255          (std-p (typep cwrapper 'wrapper))
 256          (class-slots (and std-p (wrapper-class-slots cwrapper)))
 257          (new-values
 258           (mapcar
 259            (lambda (slot-name)
 260              (cons slot-name
 261                    (if std-p
 262                        (compute-pv-slot slot-name cwrapper class class-slots)
 263                        nil)))
 264            slot-names))
 265          (pv-tables nil))
 266     (dolist (slot-name slot-names)
 267       (map-pv-table-references-of
 268        slot-name
 269        (lambda (pv-table pv-offset-list)
 270          (declare (ignore pv-offset-list))
 271          (pushnew pv-table pv-tables))))
 272     (dolist (pv-table pv-tables)
 273       (let* ((cache (pv-table-cache pv-table))
 274              (slot-name-lists (pv-table-slot-name-lists pv-table))
 275              (pv-size (pv-table-pv-size pv-table))
 276              (pv-map (make-array pv-size :initial-element nil)))
 277         (let ((map-index 0) (param-index 0))
 278           (dolist (slot-name-list slot-name-lists)
 279             (dolist (slot-name (cdr slot-name-list))
 280               (let ((a (assoc slot-name new-values)))
 281                 (setf (svref pv-map map-index)
 282                       (and a (cons param-index (cdr a)))))
 283               (incf map-index))
 284             (incf param-index)))
 285         (when cache
 286           (map-cache (lambda (wrappers pv-cell)
 287                        (update-slots-in-pv wrappers (car pv-cell)
 288                                            cwrapper pv-size pv-map))
 289                      cache))))))
 290
 291 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
 292   (if (atom wrappers)
 293       (when (eq cwrapper wrappers)
 294         (dotimes-fixnum (i pv-size)
 295           (let ((map (svref pv-map i)))
 296             (when map
 297               (aver (= (car map) 0))
 298               (setf (pvref pv i) (cdr map))))))
 299       (when (memq cwrapper wrappers)
 300         (let ((param 0))
 301           (dolist (wrapper wrappers)
 302             (when (eq wrapper cwrapper)
 303               (dotimes-fixnum (i pv-size)
 304                 (let ((map (svref pv-map i)))
 305                   (when (and map (= (car map) param))
 306                     (setf (pvref pv i) (cdr map))))))
 307             (incf param))))))
 308 \f
 309 (defun maybe-expand-accessor-form (form required-parameters slots env)
 310   (let* ((fname (car form))
 311          #||(len (length form))||#
 312          (gf (if (symbolp fname)
 313                  (unencapsulated-fdefinition fname)
 314                  (gdefinition fname))))
 315     (macrolet ((maybe-optimize-reader ()
 316                  `(let ((parameter
 317                          (can-optimize-access1 (cadr form)
 318                                                required-parameters env)))
 319                    (when parameter
 320                      (optimize-reader slots parameter gf-name form))))
 321                (maybe-optimize-writer ()
 322                  `(let ((parameter
 323                          (can-optimize-access1 (caddr form)
 324                                                required-parameters env)))
 325                    (when parameter
 326                      (optimize-writer slots parameter gf-name form)))))
 327       (unless (and (consp (cadr form))
 328                    (eq 'instance-accessor-parameter (caadr form)))
 329         (when (and (eq *boot-state* 'complete)
 330                    (generic-function-p gf))
 331           (let ((methods (generic-function-methods gf)))
 332             (when methods
 333               (let* ((gf-name (generic-function-name gf))
 334                      (arg-info (gf-arg-info gf))
 335                      (metatypes (arg-info-metatypes arg-info))
 336                      (nreq (length metatypes))
 337                      (applyp (arg-info-applyp arg-info)))
 338                 (when (null applyp)
 339                   (cond ((= nreq 1)
 340                          (when (some #'standard-reader-method-p methods)
 341                            (maybe-optimize-reader)))
 342                         ((and (= nreq 2)
 343                               (consp gf-name)
 344                               (eq (car gf-name) 'setf))
 345                          (when (some #'standard-writer-method-p methods)
 346                            (maybe-optimize-writer)))))))))))))
 347
 348 (defun optimize-generic-function-call (form
 349                                        required-parameters
 350                                        env
 351                                        slots
 352                                        calls)
 353   (declare (ignore required-parameters env slots calls))
 354   (or ; (optimize-reader ...)?
 355       form))
 356 \f
 357 (defun can-optimize-access (form required-parameters env)
 358   (let ((type (ecase (car form)
 359                 (slot-value 'reader)
 360                 (set-slot-value 'writer)
 361                 (slot-boundp 'boundp)))
 362         (var (cadr form))
 363         (slot-name (eval (caddr form)))) ; known to be constant
 364     (can-optimize-access1 var required-parameters env type slot-name)))
 365
 366 ;;; FIXME: This looks like an internal helper function for
 367 ;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
 368 ;;; bare from several places in the code. Perhaps the two functions
 369 ;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
 370 ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
 371 ;;; args instead of optional ones, too.
 372 (defun can-optimize-access1 (var required-parameters env
 373                              &optional type slot-name)
 374   (when (and (consp var) (eq 'the (car var)))
 375     ;; FIXME: We should assert list of length 3 here. Or maybe we
 376     ;; should just define EXTRACT-THE, replace the whole
 377     ;;   (WHEN ..)
 378     ;; form with
 379     ;;   (AWHEN (EXTRACT-THE VAR)
 380     ;;     (SETF VAR IT))
 381     ;; and then use EXTRACT-THE similarly to clean up the other tests
 382     ;; against 'THE scattered through the PCL code.
 383     (setq var (caddr var)))
 384   (when (symbolp var)
 385     (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
 386            (parameter-or-nil (car (memq (or rebound? var)
 387                                         required-parameters))))
 388       (when parameter-or-nil
 389         (let* ((class-name (caddr (var-declaration '%class
 390                                                    parameter-or-nil
 391                                                    env)))
 392                (class (find-class class-name nil)))
 393           (when (or (not (eq *boot-state* 'complete))
 394                     (and class (not (class-finalized-p class))))
 395             (setq class nil))
 396           (when (and class-name (not (eq class-name t)))
 397             (when (or (null type)
 398                       (not (and class
 399                                 (memq *the-class-structure-object*
 400                                       (class-precedence-list class))))
 401                       (optimize-slot-value-by-class-p class slot-name type))
 402               (cons parameter-or-nil (or class class-name)))))))))
 403
 404 ;;; Check whether the binding of the named variable is modified in the
 405 ;;; method body.
 406 (defun parameter-modified-p (parameter-name env)
 407   (let ((modified-variables (macroexpand '%parameter-binding-modified env)))
 408     (memq parameter-name modified-variables)))
 409
 410 (defun optimize-slot-value (slots sparameter form)
 411   (if sparameter
 412       (let ((optimized-form
 413              (destructuring-bind (ignore1 ignore2 slot-name-form) form
 414                (declare (ignore ignore1 ignore2))
 415                (let ((slot-name (eval slot-name-form)))
 416                  (optimize-instance-access slots :read sparameter
 417                                            slot-name nil)))))
 418         ;; We don't return the optimized form directly, since there's
 419         ;; still a chance that we'll find out later on that the
 420         ;; optimization should not have been done, for example due to
 421         ;; the walker encountering a SETQ on SPARAMETER later on in
 422         ;; the body [ see for example clos.impure.lisp test with :name
 423         ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
 424         ;; the decision until the compiler macroexpands
 425         ;; OPTIMIZED-SLOT-VALUE.
 426         ;;
 427         ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
 428         ;; this point (instead of when expanding
 429         ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
 430         ;; SLOTS. If that mutation isn't done while during the
 431         ;; walking, MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct
 432         ;; PV-BINDING form around the body, and compilation will fail.
 433         ;; -- JES, 2006-09-18
 434         `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
 435       `(accessor-slot-value ,@(cdr form))))
 436
 437 (defmacro optimized-slot-value (form parameter-name optimized-form
 438                                 &environment env)
 439   ;; Either use OPTIMIZED-FORM or fall back to the safe
 440   ;; ACCESSOR-SLOT-VALUE.
 441   (if (parameter-modified-p parameter-name env)
 442       `(accessor-slot-value ,@(cdr form))
 443       optimized-form))
 444
 445 (defun optimize-set-slot-value (slots sparameter form)
 446   (if sparameter
 447       (let ((optimized-form
 448              (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
 449                (declare (ignore ignore1 ignore2))
 450                (let ((slot-name (eval slot-name-form)))
 451                  (optimize-instance-access slots
 452                                            :write
 453                                            sparameter
 454                                            slot-name
 455                                            new-value)))))
 456         ;; See OPTIMIZE-SLOT-VALUE
 457         `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
 458       `(accessor-set-slot-value ,@(cdr form))))
 459
 460 (defmacro optimized-set-slot-value (form parameter-name optimized-form
 461                                     &environment env)
 462   (if (parameter-modified-p parameter-name env)
 463       `(accessor-set-slot-value ,@(cdr form))
 464       optimized-form))
 465
 466 (defun optimize-slot-boundp (slots sparameter form)
 467   (if sparameter
 468       (let ((optimized-form
 469              (destructuring-bind
 470                    ;; FIXME: In CMU CL ca. 19991205, this binding list
 471                    ;; had a fourth element in it, NEW-VALUE. It's hard
 472                    ;; to see how that could possibly be right, since
 473                    ;; SLOT-BOUNDP has no NEW-VALUE. Since it was
 474                    ;; causing a failure in building PCL for SBCL, so I
 475                    ;; changed it to match the definition of
 476                    ;; SLOT-BOUNDP (and also to match the list used in
 477                    ;; the similar OPTIMIZE-SLOT-VALUE,
 478                    ;; above). However, I'm weirded out by this, since
 479                    ;; this is old code which has worked for ages to
 480                    ;; build PCL for CMU CL, so it's hard to see why it
 481                    ;; should need a patch like this in order to build
 482                    ;; PCL for SBCL. I'd like to return to this and
 483                    ;; find a test case which exercises this function
 484                    ;; both in CMU CL, to see whether it's really a
 485                    ;; previously-unexercised bug or whether I've
 486                    ;; misunderstood something (and, presumably,
 487                    ;; patched it wrong).
 488                    (slot-boundp-symbol instance slot-name-form)
 489                  form
 490                (declare (ignore slot-boundp-symbol instance))
 491                (let ((slot-name (eval slot-name-form)))
 492                  (optimize-instance-access slots
 493                                            :boundp
 494                                            sparameter
 495                                            slot-name
 496                                            nil)))))
 497         ;; See OPTIMIZE-SLOT-VALUE
 498         `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
 499       `(accessor-slot-boundp ,@(cdr form))))
 500
 501 (defmacro optimized-slot-boundp (form parameter-name optimized-form
 502                                  &environment env)
 503   (if (parameter-modified-p parameter-name env)
 504       `(accessor-slot-boundp ,@(cdr form))
 505       optimized-form))
 506
 507 (defun optimize-reader (slots sparameter gf-name form)
 508   (if sparameter
 509       (optimize-accessor-call slots :read sparameter gf-name nil)
 510       form))
 511
 512 (defun optimize-writer (slots sparameter gf-name form)
 513   (if sparameter
 514       (destructuring-bind (ignore1 ignore2 new-value) form
 515         (declare (ignore ignore1 ignore2))
 516         (optimize-accessor-call slots :write sparameter gf-name new-value))
 517       form))
 518
 519 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
 520 ;;; of a required parameter to the function. The alist is in order, so
 521 ;;; the position of an entry in the alist corresponds to the
 522 ;;; argument's position in the lambda list.
 523 (defun optimize-instance-access (slots
 524                                  read/write
 525                                  sparameter
 526                                  slot-name
 527                                  new-value)
 528   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
 529         (parameter (if (consp sparameter) (car sparameter) sparameter)))
 530     (if (and (eq *boot-state* 'complete)
 531              (classp class)
 532              (memq *the-class-structure-object* (class-precedence-list class)))
 533         (let ((slotd (find-slot-definition class slot-name)))
 534           (ecase read/write
 535             (:read
 536              `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
 537             (:write
 538              `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
 539                      ,parameter)
 540                     ,new-value))
 541             (:boundp
 542              t)))
 543         (let* ((parameter-entry (assq parameter slots))
 544                (slot-entry      (assq slot-name (cdr parameter-entry)))
 545                (position (posq parameter-entry slots))
 546                (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
 547           (unless parameter-entry
 548             (bug "slot optimization bewilderment: O-I-A"))
 549           (unless slot-entry
 550             (setq slot-entry (list slot-name))
 551             (push slot-entry (cdr parameter-entry)))
 552           (push pv-offset-form (cdr slot-entry))
 553           (ecase read/write
 554             (:read
 555              `(instance-read ,pv-offset-form ,parameter ,position
 556                              ',slot-name ',class))
 557             (:write
 558              `(let ((.new-value. ,new-value))
 559                 (instance-write ,pv-offset-form ,parameter ,position
 560                                 ',slot-name ',class .new-value.)))
 561             (:boundp
 562              `(instance-boundp ,pv-offset-form ,parameter ,position
 563                                ',slot-name ',class)))))))
 564
 565 (defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
 566   (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
 567          (parameter (if (consp sparameter) (car sparameter) sparameter))
 568          (parameter-entry (assq parameter slots))
 569          (name (case read/write
 570                  (:read `(reader ,gf-name))
 571                  (:write `(writer ,gf-name))))
 572          (slot-entry      (assoc name (cdr parameter-entry) :test #'equal))
 573          (position (posq parameter-entry slots))
 574          (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
 575     (unless parameter-entry
 576       (error "slot optimization bewilderment: O-A-C"))
 577     (unless slot-entry
 578       (setq slot-entry (list name))
 579       (push slot-entry (cdr parameter-entry)))
 580     (push pv-offset-form (cdr slot-entry))
 581     (ecase read/write
 582       (:read
 583        `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
 584       (:write
 585        `(let ((.new-value. ,new-value))
 586           (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
 587                            .new-value.))))))
 588
 589 (defvar *unspecific-arg* '..unspecific-arg..)
 590
 591 (defun optimize-gf-call-internal (form slots env)
 592   (when (and (consp form)
 593              (eq (car form) 'the))
 594     (setq form (caddr form)))
 595   (or (and (symbolp form)
 596            (let* ((rebound? (caddr (var-declaration '%variable-rebinding
 597                                                     form
 598                                                     env)))
 599                   (parameter-or-nil (car (assq (or rebound? form) slots))))
 600              (when parameter-or-nil
 601                (let* ((class-name (caddr (var-declaration 'class
 602                                                           parameter-or-nil
 603                                                           env))))
 604                  (when (and class-name (not (eq class-name t)))
 605                    (position parameter-or-nil slots :key #'car))))))
 606       (if (constantp form)
 607           (let ((form (constant-form-value form)))
 608             (if (symbolp form)
 609                 form
 610                 *unspecific-arg*))
 611           *unspecific-arg*)))
 612
 613 (defun optimize-gf-call (slots calls gf-call-form nreq restp env)
 614   (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
 615     (let* ((args (cdr gf-call-form))
 616            (all-args-p (eq (car gf-call-form) 'make-instance))
 617            (non-required-args (nthcdr nreq args))
 618            (required-args (ldiff args non-required-args))
 619            (call-spec (list (car gf-call-form) nreq restp
 620                             (mapcar (lambda (form)
 621                                       (optimize-gf-call-internal form slots env))
 622                                     (if all-args-p
 623                                         args
 624                                         required-args))))
 625            (call-entry (assoc call-spec calls :test #'equal))
 626            (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
 627       (unless (some #'integerp
 628                     (let ((spec-args (cdr call-spec)))
 629                       (if all-args-p
 630                           (ldiff spec-args (nthcdr nreq spec-args))
 631                           spec-args)))
 632         (return-from optimize-gf-call nil))
 633       (unless call-entry
 634         (setq call-entry (list call-spec))
 635         (push call-entry (cdr calls)))
 636       (push pv-offset-form (cdr call-entry))
 637       (if (eq (car call-spec) 'make-instance)
 638           `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
 639           `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
 640             (invoke-effective-method-function .emf. ,restp
 641              ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
 642
 643 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
 644 (defmacro pv-offset (arg) arg)
 645 (define-walker-template instance-accessor-parameter)
 646 (defmacro instance-accessor-parameter (x) x)
 647
 648 ;;; It is safe for these two functions to be wrong. They just try to
 649 ;;; guess what the most likely case will be.
 650 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
 651   (let ((class (and (constantp class-form) (constant-form-value class-form)))
 652         (slot-name (and (constantp slot-name-form)
 653                         (constant-form-value slot-name-form))))
 654     (and (eq *boot-state* 'complete)
 655          (standard-class-p class)
 656          (not (eq class *the-class-t*)) ; shouldn't happen, though.
 657          (let ((slotd (find-slot-definition class slot-name)))
 658            (and slotd (eq :class (slot-definition-allocation slotd)))))))
 659
 660 (defun skip-fast-slot-access-p (class-form slot-name-form type)
 661   (let ((class (and (constantp class-form) (constant-form-value class-form)))
 662         (slot-name (and (constantp slot-name-form)
 663                         (constant-form-value slot-name-form))))
 664     (and (eq *boot-state* 'complete)
 665          (standard-class-p class)
 666          (not (eq class *the-class-t*)) ; shouldn't happen, though.
 667          (let ((slotd (find-slot-definition class slot-name)))
 668            (and slotd (skip-optimize-slot-value-by-class-p class
 669                                                            slot-name
 670                                                            type))))))
 671
 672 (defun skip-optimize-slot-value-by-class-p (class slot-name type)
 673   (let ((slotd (find-slot-definition class slot-name)))
 674     (and slotd
 675          (eq *boot-state* 'complete)
 676          (not (slot-accessor-std-p slotd type)))))
 677
 678 (defmacro instance-read-internal (pv slots pv-offset default &optional type)
 679   (unless (member type '(nil :instance :class :default))
 680     (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
 681   (if (eq type :default)
 682       default
 683       (let* ((index (gensym))
 684              (value index))
 685         `(locally (declare #.*optimize-speed*)
 686           (let ((,index (pvref ,pv ,pv-offset)))
 687             (setq ,value (typecase ,index
 688                            ;; FIXME: the line marked by KLUDGE below
 689                            ;; (and the analogous spot in
 690                            ;; INSTANCE-WRITE-INTERNAL) is there purely
 691                            ;; to suppress a type mismatch warning that
 692                            ;; propagates through to user code.
 693                            ;; Presumably SLOTS at this point can never
 694                            ;; actually be NIL, but the compiler seems
 695                            ;; to think it could, so we put this here
 696                            ;; to shut it up.  (see also mail Rudi
 697                            ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
 698                            ;; 2003-11-30
 699                            ,@(when (or (null type) (eq type :instance))
 700                                `((fixnum
 701                                   (and ,slots ; KLUDGE
 702                                    (clos-slots-ref ,slots ,index)))))
 703                            ,@(when (or (null type) (eq type :class))
 704                                `((cons (cdr ,index))))
 705                            (t +slot-unbound+)))
 706             (if (eq ,value +slot-unbound+)
 707                 ,default
 708                 ,value))))))
 709
 710 (defmacro instance-read (pv-offset parameter position slot-name class)
 711   (if (skip-fast-slot-access-p class slot-name 'reader)
 712       `(accessor-slot-value ,parameter ,slot-name)
 713       `(instance-read-internal .pv. ,(slot-vector-symbol position)
 714         ,pv-offset (accessor-slot-value ,parameter ,slot-name)
 715         ,(if (generate-fast-class-slot-access-p class slot-name)
 716              :class :instance))))
 717
 718 (defmacro instance-reader (pv-offset parameter position gf-name class)
 719   (declare (ignore class))
 720   `(instance-read-internal .pv. ,(slot-vector-symbol position)
 721     ,pv-offset
 722     (,gf-name (instance-accessor-parameter ,parameter))
 723     :instance))
 724
 725 (defmacro instance-write-internal (pv slots pv-offset new-value default
 726                                       &optional type)
 727   (unless (member type '(nil :instance :class :default))
 728     (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
 729   (if (eq type :default)
 730       default
 731       (let* ((index (gensym)))
 732         `(locally (declare #.*optimize-speed*)
 733           (let ((,index (pvref ,pv ,pv-offset)))
 734             (typecase ,index
 735               ,@(when (or (null type) (eq type :instance))
 736                   `((fixnum (and ,slots
 737                              (setf (clos-slots-ref ,slots ,index)
 738                                    ,new-value)))))
 739               ,@(when (or (null type) (eq type :class))
 740                   `((cons (setf (cdr ,index) ,new-value))))
 741               (t ,default)))))))
 742
 743 (defmacro instance-write (pv-offset
 744                           parameter
 745                           position
 746                           slot-name
 747                           class
 748                           new-value)
 749   (if (skip-fast-slot-access-p class slot-name 'writer)
 750       `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
 751       `(instance-write-internal .pv. ,(slot-vector-symbol position)
 752         ,pv-offset ,new-value
 753         (accessor-set-slot-value ,parameter ,slot-name ,new-value)
 754         ,(if (generate-fast-class-slot-access-p class slot-name)
 755              :class :instance))))
 756
 757 (defmacro instance-writer (pv-offset
 758                            parameter
 759                            position
 760                            gf-name
 761                            class
 762                            new-value)
 763   (declare (ignore class))
 764   `(instance-write-internal .pv. ,(slot-vector-symbol position)
 765     ,pv-offset ,new-value
 766     (,(if (consp gf-name)
 767           (get-setf-fun-name gf-name)
 768           gf-name)
 769      (instance-accessor-parameter ,parameter)
 770      ,new-value)
 771     :instance))
 772
 773 (defmacro instance-boundp-internal (pv slots pv-offset default
 774                                        &optional type)
 775   (unless (member type '(nil :instance :class :default))
 776     (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
 777   (if (eq type :default)
 778       default
 779       (let* ((index (gensym)))
 780         `(locally (declare #.*optimize-speed*)
 781           (let ((,index (pvref ,pv ,pv-offset)))
 782             (typecase ,index
 783               ,@(when (or (null type) (eq type :instance))
 784                   `((fixnum (not (and ,slots
 785                                       (eq (clos-slots-ref ,slots ,index)
 786                                           +slot-unbound+))))))
 787               ,@(when (or (null type) (eq type :class))
 788                   `((cons (not (eq (cdr ,index) +slot-unbound+)))))
 789               (t ,default)))))))
 790
 791 (defmacro instance-boundp (pv-offset parameter position slot-name class)
 792   (if (skip-fast-slot-access-p class slot-name 'boundp)
 793       `(accessor-slot-boundp ,parameter ,slot-name)
 794       `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
 795         ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
 796         ,(if (generate-fast-class-slot-access-p class slot-name)
 797              :class :instance))))
 798
 799 ;;; This magic function has quite a job to do indeed.
 800 ;;;
 801 ;;; The careful reader will recall that <slots> contains all of the
 802 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
 803 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
 804 ;;;
 805 ;;; At the time these calls were produced, the first argument was
 806 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
 807 ;;; convert those pv-offset arguments into the actual number that is
 808 ;;; the correct offset into the pv.
 809 ;;;
 810 ;;; But first, oh but first, we sort <slots> a bit so that for each
 811 ;;; argument we have the slots in alphabetical order. This
 812 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
 813 ;;; having fewer PV's floating around. Even if the gain is only
 814 ;;; modest, it costs nothing.
 815 (defun slot-name-lists-from-slots (slots calls)
 816   (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
 817     (let* ((slot-name-lists
 818             (mapcar (lambda (parameter-entry)
 819                       (cons nil (mapcar #'car (cdr parameter-entry))))
 820                     slots))
 821            (call-list
 822             (mapcar #'car calls)))
 823       (dolist (call call-list)
 824         (dolist (arg (cdr call))
 825           (when (integerp arg)
 826             (setf (car (nth arg slot-name-lists)) t))))
 827       (setq slot-name-lists (mapcar (lambda (r+snl)
 828                                       (when (or (car r+snl) (cdr r+snl))
 829                                         r+snl))
 830                                     slot-name-lists))
 831       (let ((cvt (apply #'vector
 832                         (let ((i -1))
 833                           (mapcar (lambda (r+snl)
 834                                     (when r+snl (incf i)))
 835                                   slot-name-lists)))))
 836         (setq call-list (mapcar (lambda (call)
 837                                   (cons (car call)
 838                                         (mapcar (lambda (arg)
 839                                                   (if (integerp arg)
 840                                                       (svref cvt arg)
 841                                                       arg))
 842                                                 (cdr call))))
 843                                 call-list)))
 844       (values slot-name-lists call-list))))
 845
 846 (defun mutate-slots-and-calls (slots calls)
 847   (let ((sorted-slots (sort-slots slots))
 848         (sorted-calls (sort-calls (cdr calls)))
 849         (pv-offset -1))
 850     (dolist (parameter-entry sorted-slots)
 851       (dolist (slot-entry (cdr parameter-entry))
 852         (incf pv-offset)
 853         (dolist (form (cdr slot-entry))
 854           (setf (cadr form) pv-offset))))
 855     (dolist (call-entry sorted-calls)
 856       (incf pv-offset)
 857       (dolist (form (cdr call-entry))
 858         (setf (cadr form) pv-offset)))
 859     (values sorted-slots sorted-calls)))
 860
 861 (defun symbol-pkg-name (sym)
 862   (let ((pkg (symbol-package sym)))
 863     (if pkg (package-name pkg) "")))
 864
 865 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
 866 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
 867 ;;; stable. This ordering is only used in to
 868 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
 869 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
 870 ;;; floating around", so it sounds as though the instability won't
 871 ;;; actually lead to bugs, just small inefficiency. But still, it
 872 ;;; would be better to reimplement this function as a comparison based
 873 ;;; on SYMBOL-HASH:
 874 ;;;   * stable comparison
 875 ;;;   * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
 876 ;;;   * faster code.
 877 (defun symbol-lessp (a b)
 878   (if (eq (symbol-package a)
 879           (symbol-package b))
 880       (string-lessp (symbol-name a)
 881                     (symbol-name b))
 882       (string-lessp (symbol-pkg-name a)
 883                     (symbol-pkg-name b))))
 884
 885 (defun symbol-or-cons-lessp (a b)
 886   (etypecase a
 887     (symbol (etypecase b
 888               (symbol (symbol-lessp a b))
 889               (cons t)))
 890     (cons   (etypecase b
 891               (symbol nil)
 892               (cons (if (eq (car a) (car b))
 893                         (symbol-or-cons-lessp (cdr a) (cdr b))
 894                         (symbol-or-cons-lessp (car a) (car b))))))))
 895
 896 (defun sort-slots (slots)
 897   (mapcar (lambda (parameter-entry)
 898             (cons (car parameter-entry)
 899                   (sort (cdr parameter-entry)   ;slot entries
 900                         #'symbol-or-cons-lessp
 901                         :key #'car)))
 902           slots))
 903
 904 (defun sort-calls (calls)
 905   (sort calls #'symbol-or-cons-lessp :key #'car))
 906 \f
 907 ;;;; This needs to work in terms of metatypes and also needs to work
 908 ;;;; for automatically generated reader and writer functions.
 909 ;;;; Automatically generated reader and writer functions use this
 910 ;;;; stuff too.
 911
 912 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
 913                       &body body)
 914   (let (slot-vars pv-parameters)
 915     (loop for slots in slot-name-lists
 916           for required-parameter in required-parameters
 917           for i from 0
 918           do (when slots
 919                (push required-parameter pv-parameters)
 920                (push (slot-vector-symbol i) slot-vars)))
 921     `(pv-binding1 (.pv. .calls. ,pv-table-form
 922                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
 923        ,@body)))
 924
 925 (defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
 926                        &body body)
 927   `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
 928      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
 929                      slot-vars pv-parameters))
 930        (declare (ignorable ,@(mapcar #'identity slot-vars)))
 931        ,@body)))
 932
 933 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
 934 ;;; overridden.
 935 (define-symbol-macro pv-env-environment overridden)
 936
 937 (defmacro pv-env (&environment env
 938                   (pv calls pv-table-form pv-parameters)
 939                   &rest forms)
 940   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
 941   ;; symbol-macrolet.
 942   (if (eq (macroexpand 'pv-env-environment env) 'default)
 943       `(let ((,pv (car .pv-cell.))
 944              (,calls (cdr .pv-cell.)))
 945          (declare ,(make-pv-type-declaration pv)
 946                   ,(make-calls-type-declaration calls))
 947          ,pv ,calls
 948          ,@forms)
 949       `(let* ((.pv-table. ,pv-table-form)
 950               (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
 951               (,pv (car .pv-cell.))
 952               (,calls (cdr .pv-cell.)))
 953         (declare ,(make-pv-type-declaration pv))
 954         (declare ,(make-calls-type-declaration calls))
 955         ,pv ,calls
 956         ,@forms)))
 957
 958 (defvar *non-var-declarations*
 959   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
 960   ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
 961   ;; SBCL doesn't have 'em, VALUES should probably be removed from
 962   ;; this list.
 963   '(values
 964     %method-name
 965     %method-lambda-list
 966     optimize
 967     ftype
 968     inline
 969     notinline))
 970
 971 (defvar *var-declarations-with-arg*
 972   '(%class
 973     type))
 974
 975 (defvar *var-declarations-without-arg*
 976   '(ignore
 977     ignorable special dynamic-extent
 978     ;; FIXME: Possibly this entire list and variable could go away.
 979     ;; If not, certainly we should remove all these built-in typenames
 980     ;; from the list, and replace them with a test for "is it a type
 981     ;; name?" (CLTL1 allowed only built-in type names as declarations,
 982     ;; but ANSI CL allows any type name as a declaration.)
 983     array atom base-char bignum bit bit-vector character compiled-function
 984     complex cons double-float extended-char
 985     fixnum float function hash-table integer
 986     keyword list long-float nil null number package pathname random-state ratio
 987     rational readtable sequence short-float signed-byte simple-array
 988     simple-bit-vector simple-string simple-vector single-float standard-char
 989     stream string symbol t unsigned-byte vector))
 990
 991 (defun split-declarations (body args maybe-reads-params-p)
 992   (let ((inner-decls nil)
 993         (outer-decls nil)
 994         decl)
 995     (loop (when (null body) (return nil))
 996           (setq decl (car body))
 997           (unless (and (consp decl)
 998                        (eq (car decl) 'declare))
 999             (return nil))
1000           (dolist (form (cdr decl))
1001             (when (consp form)
1002               (let ((declaration-name (car form)))
1003                 (if (member declaration-name *non-var-declarations*)
1004                     (push `(declare ,form) outer-decls)
1005                     (let ((arg-p
1006                            (member declaration-name
1007                                    *var-declarations-with-arg*))
1008                           (non-arg-p
1009                            (member declaration-name
1010                                    *var-declarations-without-arg*))
1011                           (dname (list (pop form)))
1012                           (inners nil) (outers nil))
1013                       (unless (or arg-p non-arg-p)
1014                         ;; FIXME: This warning, and perhaps the
1015                         ;; various *VAR-DECLARATIONS-FOO* and/or
1016                         ;; *NON-VAR-DECLARATIONS* variables,
1017                         ;; could probably go away now that we're not
1018                         ;; trying to be portable between different
1019                         ;; CLTL1 hosts the way PCL was. (Note that to
1020                         ;; do this right, we need to be able to handle
1021                         ;; user-defined (DECLAIM (DECLARATION FOO))
1022                         ;; stuff.)
1023                         (warn "The declaration ~S is not understood by ~S.~@
1024                                Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
1025                         (Assuming it is a variable declaration without argument)."
1026                               declaration-name 'split-declarations
1027                               declaration-name
1028                               '*non-var-declarations*
1029                               '*var-declarations-with-arg*
1030                               '*var-declarations-without-arg*)
1031                         (push declaration-name *var-declarations-without-arg*))
1032                       (when arg-p
1033                         (setq dname (append dname (list (pop form)))))
1034                       (case (car dname)
1035                         (%class (push `(declare (,@dname ,@form)) inner-decls))
1036                         (t
1037                          (dolist (var form)
1038                            (if (member var args)
1039                                ;; Quietly remove IGNORE declarations
1040                                ;; on args when a next-method is
1041                                ;; involved, to prevent compiler
1042                                ;; warnings about ignored args being
1043                                ;; read.
1044                                (unless (and maybe-reads-params-p
1045                                             (eq (car dname) 'ignore))
1046                                  (push var outers))
1047                                (push var inners)))
1048                          (when outers
1049                            (push `(declare (,@dname ,@outers)) outer-decls))
1050                          (when inners
1051                            (push
1052                             `(declare (,@dname ,@inners))
1053                             inner-decls)))))))))
1054           (setq body (cdr body)))
1055     (values outer-decls inner-decls body)))
1056
1057 ;;; Pull a name out of the %METHOD-NAME declaration in the function
1058 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
1059 (defun body-method-name (body)
1060   (multiple-value-bind (real-body declarations documentation)
1061       (parse-body body)
1062     (declare (ignore real-body documentation))
1063     (let ((name-decl (get-declaration '%method-name declarations)))
1064       (and name-decl
1065            (destructuring-bind (name) name-decl
1066              name)))))
1067
1068 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
1069 ;;; declaration (which is a naming style internal to PCL) into an
1070 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
1071 ;;; throughout SBCL, understood by the main compiler); or if there's
1072 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
1073 ;;; lambda expression.
1074 (defun name-method-lambda (method-lambda)
1075   (let ((method-name (body-method-name (cddr method-lambda))))
1076     (if method-name
1077         `(named-lambda (slow-method ,method-name) ,(rest method-lambda))
1078         method-lambda)))
1079
1080 (defun make-method-initargs-form-internal (method-lambda initargs env)
1081   (declare (ignore env))
1082   (let (method-lambda-args
1083         lmf ; becomes body of function
1084         lmf-params)
1085     (if (not (and (= 3 (length method-lambda))
1086                   (= 2 (length (setq method-lambda-args (cadr method-lambda))))
1087                   (consp (setq lmf (third method-lambda)))
1088                   (eq 'simple-lexical-method-functions (car lmf))
1089                   (eq (car method-lambda-args)
1090                       (cadr (setq lmf-params (cadr lmf))))
1091                   (eq (cadr method-lambda-args)
1092                       (caddr lmf-params))))
1093         `(list* :function ,(name-method-lambda method-lambda)
1094                 ',initargs)
1095         (let* ((lambda-list (car lmf-params))
1096                (nreq 0)
1097                (restp nil)
1098                (args nil))
1099           (dolist (arg lambda-list)
1100             (when (member arg '(&optional &rest &key))
1101               (setq restp t)
1102               (return nil))
1103             (when (eq arg '&aux)
1104               (return nil))
1105             (incf nreq)
1106             (push arg args))
1107           (setq args (nreverse args))
1108           (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
1109           (make-method-initargs-form-internal1
1110            initargs (cddr lmf) args lmf-params restp)))))
1111
1112 (defun make-method-initargs-form-internal1
1113     (initargs body req-args lmf-params restp)
1114   (multiple-value-bind (outer-decls inner-decls body-sans-decls)
1115       (split-declarations
1116        body req-args (or (getf (cdr lmf-params) :call-next-method-p)
1117                          (getf (cdr lmf-params) :setq-p)))
1118     (let* ((rest-arg (when restp '.rest-arg.))
1119            (args+rest-arg (if restp
1120                               (append req-args (list rest-arg))
1121                               req-args)))
1122       `(list*
1123         :function
1124         (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
1125                      ,@(when (body-method-name body)
1126                          ;; function name
1127                          (list (cons 'fast-method (body-method-name body))))
1128                      (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
1129                      ;; body of the function
1130                      (declare (ignorable .pv-cell. .next-method-call.)
1131                               (disable-package-locks pv-env-environment))
1132                      ,@outer-decls
1133                      (symbol-macrolet ((pv-env-environment default))
1134                          (fast-lexical-method-functions
1135                           (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
1136                             ,@(cdddr lmf-params))
1137                           ,@inner-decls
1138                           ,@body-sans-decls))))
1139               (mf (%make-method-function fmf nil)))
1140           (set-funcallable-instance-function
1141            mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
1142           mf)
1143         ',initargs))))
1144
1145 ;;; Use arrays and hash tables and the fngen stuff to make this much
1146 ;;; better. It doesn't really matter, though, because a function
1147 ;;; returned by this will get called only when the user explicitly
1148 ;;; funcalls a result of method-function. BUT, this is needed to make
1149 ;;; early methods work.
1150 (defun method-function-from-fast-function (fmf plist)
1151   (declare (type function fmf))
1152   (let* ((method-function nil)
1153          (calls (getf plist :call-list))
1154          (snl (getf plist :slot-name-lists))
1155          (pv-table (when (or calls snl)
1156                      (intern-pv-table :call-list calls :slot-name-lists snl)))
1157          (arg-info (getf plist :arg-info))
1158          (nreq (car arg-info))
1159          (restp (cdr arg-info)))
1160     (setq method-function
1161           (lambda (method-args next-methods)
1162             (let* ((pv-cell (when pv-table
1163                               (get-pv-cell method-args pv-table)))
1164                    (nm (car next-methods))
1165                    (nms (cdr next-methods))
1166                    (nmc (when nm
1167                           (make-method-call
1168                            :function (if (std-instance-p nm)
1169                                          (method-function nm)
1170                                          nm)
1171                            :call-method-args (list nms)))))
1172               (if restp
1173                   (let* ((rest (nthcdr nreq method-args))
1174                          (args (ldiff method-args rest)))
1175                     (apply fmf pv-cell nmc (nconc args (list rest))))
1176                   (apply fmf pv-cell nmc method-args)))))
1177     ;; FIXME: this looks dangerous.
1178     (let* ((fname (%fun-name fmf)))
1179       (when (and fname (eq (car fname) 'fast-method))
1180         (set-fun-name method-function (cons 'slow-method (cdr fname)))))
1181     method-function))
1182
1183 ;;; this is similar to the above, only not quite.  Only called when
1184 ;;; the MOP is heavily involved.  Not quite parallel to
1185 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
1186 ;;; over the actual PV-CELL in this case.
1187 (defun method-function-from-fast-method-call (fmc)
1188   (let* ((fmf (fast-method-call-function fmc))
1189          (pv-cell (fast-method-call-pv-cell fmc))
1190          (arg-info (fast-method-call-arg-info fmc))
1191          (nreq (car arg-info))
1192          (restp (cdr arg-info)))
1193     (lambda (method-args next-methods)
1194       (let* ((nm (car next-methods))
1195              (nms (cdr next-methods))
1196              (nmc (when nm
1197                     (make-method-call
1198                      :function (if (std-instance-p nm)
1199                                    (method-function nm)
1200                                    nm)
1201                      :call-method-args (list nms)))))
1202         (if restp
1203             (let* ((rest (nthcdr nreq method-args))
1204                    (args (ldiff method-args rest)))
1205               (apply fmf pv-cell nmc (nconc args (list rest))))
1206             (apply fmf pv-cell nmc method-args))))))
1207
1208 (defun get-pv-cell (method-args pv-table)
1209   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
1210     (when pv-wrappers
1211       (pv-table-lookup pv-table pv-wrappers))))
1212
1213 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
1214   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
1215
1216 (defun pv-wrappers-from-pv-args (&rest args)
1217   (let (wrappers)
1218     (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
1219       (let ((wrapper (wrapper-of arg)))
1220         (push (if (invalid-wrapper-p wrapper)
1221                   (check-wrapper-validity wrapper)
1222                   wrapper)
1223               wrappers)))))
1224
1225 (defun pv-wrappers-from-all-args (pv-table args)
1226   (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
1227         when snl
1228           collect (wrapper-of arg) into wrappers
1229         finally (return (if (cdr wrappers) wrappers (car wrappers)))))
1230
1231 ;;; Return the subset of WRAPPERS which is used in the cache
1232 ;;; of PV-TABLE.
1233 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
1234   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
1235         when snl
1236           collect w into result
1237         finally (return (if (cdr result) result (car result)))))