src/pcl/construct.lisp

   1 ;;;; This file defines MAKE-INSTANCE optimization mechanisms.
   2 ;;;;
   3 ;;;; KLUDGE: I removed the old DEFCONSTRUCTOR, MAKE-CONSTRUCTOR, and
   4 ;;;; LOAD-CONSTRUCTOR families of definitions in sbcl-0.pre7.99, since
   5 ;;;; it was clear from a few minutes with egrep that they were dead
   6 ;;;; code, but I suspect more dead code remains in this file. (Maybe
   7 ;;;; it's all dead?) -- WHN 2001-12-26
   8
   9 ;;;; This software is part of the SBCL system. See the README file for
  10 ;;;; more information.
  11
  12 ;;;; This software is derived from software originally released by Xerox
  13 ;;;; Corporation. Copyright and release statements follow. Later modifications
  14 ;;;; to the software are in the public domain and are provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  16 ;;;; information.
  17
  18 ;;;; copyright information from original PCL sources:
  19 ;;;;
  20 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  21 ;;;; All rights reserved.
  22 ;;;;
  23 ;;;; Use and copying of this software and preparation of derivative works based
  24 ;;;; upon this software are permitted. Any distribution of this software or
  25 ;;;; derivative works must comply with all applicable United States export
  26 ;;;; control laws.
  27 ;;;;
  28 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  29 ;;;; warranty about the software, its performance or its conformity to any
  30 ;;;; specification.
  31
  32 (in-package "SB-PCL")
  33 \f
  34 ;;; The actual constructor objects.
  35 (defclass constructor (funcallable-standard-object)
  36      ((class                                    ;The class with which this
  37         :initarg :class                         ;constructor is associated.
  38         :reader constructor-class)              ;The actual class object,
  39                                                 ;not the class name.
  40
  41       (name                                     ;The name of this constructor.
  42         :initform nil                           ;This is the symbol in whose
  43         :initarg :name                          ;function cell the constructor
  44         :reader constructor-name)               ;usually sits. Of course, this
  45                                                 ;is optional. The old
  46                                                 ;DEFCONSTRUCTOR macro made
  47                                                 ;named constructors, but
  48                                                 ;it is possible to manipulate
  49                                                 ;anonymous constructors also.
  50
  51       (code-type                                ;The type of code currently in
  52         :initform nil                           ;use by this constructor. This
  53         :accessor constructor-code-type)        ;is mostly for debugging and
  54                                                 ;analysis purposes.
  55                                                 ;The lazy installer sets this
  56                                                 ;to LAZY. The most basic and
  57                                                 ;least optimized type of code
  58                                                 ;is called FALLBACK.
  59
  60       (supplied-initarg-names                   ;The names of the initargs this
  61         :initarg :supplied-initarg-names        ;constructor supplies when it
  62         :reader                                 ;"calls" make-instance.
  63            constructor-supplied-initarg-names)  ;
  64
  65       (code-generators                          ;Generators for the different
  66         :initarg :code-generators               ;types of code this constructor
  67         :reader constructor-code-generators))   ;could use.
  68   (:metaclass funcallable-standard-class))
  69
  70 (defmethod describe-object ((constructor constructor) stream)
  71   (format stream
  72           "~S is a constructor for the class ~S.~%~
  73             The current code type is ~S.~%~
  74             Other possible code types are ~S."
  75           constructor (constructor-class constructor)
  76           (constructor-code-type constructor)
  77           (let ((collect nil))
  78             (doplist (key val) (constructor-code-generators constructor)
  79               (push key collect))
  80             (nreverse collect))))
  81 \f
  82 ;;;; Here is the actual smarts for making the code generators and then
  83 ;;;; trying each generator to get constructor code. This extensible
  84 ;;;; mechanism allows new kinds of constructor code types to be added.
  85 ;;;; A programmer defining a specialization of the constructor class
  86 ;;;; can use this mechanism to define new code types.
  87 ;;;;
  88 ;;;; original PCL comment from before dead DEFCONSTRUCTOR was deleted:
  89 ;;;;   The function defined by define-constructor-code-type will receive
  90 ;;;;   the class object, and the 4 original arguments to DEFCONSTRUCTOR.
  91 ;;;;   It can return a constructor code generator, or return NIL if this
  92 ;;;;   type of code is determined to not be appropriate after looking at
  93 ;;;;   the DEFCONSTRUCTOR arguments.
  94 ;;;;
  95 ;;;; original PCL comment from before dead COMPUTE-CONSTRUCTOR-CODE
  96 ;;;; was deleted:
  97 ;;;;    When compute-constructor-code is called, it first performs
  98 ;;;;    basic checks to make sure that the basic assumptions common to
  99 ;;;;    all the code types are valid. (For details see method
 100 ;;;;    definition). If any of the tests fail, the fallback
 101 ;;;;    constructor code type is used. If none of the tests fail, the
 102 ;;;;    constructor code generators are called in order. They receive
 103 ;;;;    5 arguments:
 104 ;;;;
 105 ;;;;   CLASS    the class the constructor is making instances of
 106 ;;;;   WRAPPER      that class's wrapper
 107 ;;;;   DEFAULTS     the result of calling class-default-initargs on class
 108 ;;;;   INITIALIZE   the applicable methods on initialize-instance
 109 ;;;;   SHARED       the applicable methosd on shared-initialize
 110 ;;;;
 111 ;;;; The first code generator to return code is used. The code
 112 ;;;; generators are called in reverse order of definition, so
 113 ;;;; DEFINE-CONSTRUCTOR-CODE-TYPE forms which define better code
 114 ;;;; should appear after ones that define less good code. The fallback
 115 ;;;; code type appears first. Note that redefining a code type does
 116 ;;;; not change its position in the list. To do that, define a new
 117 ;;;; type at the end with the behavior.
 118
 119 (defvar *constructor-code-types* ())
 120
 121 (defmacro define-constructor-code-type (type arglist &body body)
 122   (let ((fn-name (intern (format nil
 123                                  "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
 124                                  (package-name (symbol-package type))
 125                                  (symbol-name type))
 126                          *pcl-package*)))
 127     `(progn
 128        (defun ,fn-name ,arglist .,body)
 129        (load-define-constructor-code-type ',type ',fn-name))))
 130
 131 (defun load-define-constructor-code-type (type generator)
 132   (let ((old-entry (assq type *constructor-code-types*)))
 133     (if old-entry
 134         (setf (cadr old-entry) generator)
 135         (push (list type generator) *constructor-code-types*))
 136     type))
 137 \f
 138 ;;;; helper functions and utilities that are shared by all of the code
 139 ;;;; types
 140
 141 (defvar *standard-initialize-instance-method*
 142         (get-method #'initialize-instance
 143                     ()
 144                     (list *the-class-slot-object*)))
 145
 146 (defvar *standard-shared-initialize-method*
 147         (get-method #'shared-initialize
 148                     ()
 149                     (list *the-class-slot-object* *the-class-t*)))
 150
 151 (defun non-pcl-initialize-instance-methods-p (methods)
 152   (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
 153             methods))
 154
 155 (defun non-pcl-shared-initialize-methods-p (methods)
 156   (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
 157             methods))
 158
 159 (defun non-pcl-or-after-initialize-instance-methods-p (methods)
 160   (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
 161                               (equal '(:after) (method-qualifiers m))))
 162             methods))
 163
 164 (defun non-pcl-or-after-shared-initialize-methods-p (methods)
 165   (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
 166                               (equal '(:after) (method-qualifiers m))))
 167             methods))
 168
 169 ;;; This returns two values. The first is a vector which can be used as the
 170 ;;; initial value of the slots vector for the instance. The second is a symbol
 171 ;;; describing the initforms this class has.
 172 ;;;
 173 ;;;  If the first value is:
 174 ;;;
 175 ;;;    :UNSUPPLIED    no slot has an initform
 176 ;;;    :CONSTANTS     all slots have either a constant initform
 177 ;;;                   or no initform at all
 178 ;;;    T              there is at least one non-constant initform
 179 (defun compute-constant-vector (class)
 180   ;;(declare (values constants flag))
 181   (let* ((wrapper (class-wrapper class))
 182          (layout (wrapper-instance-slots-layout wrapper))
 183          (flag :unsupplied)
 184          (constants ()))
 185     (dolist (slotd (class-slots class))
 186       (let ((name (slot-definition-name slotd))
 187             (initform (slot-definition-initform slotd))
 188             (initfn (slot-definition-initfunction slotd)))
 189         (cond ((null (memq name layout)))
 190               ((null initfn)
 191                (push (cons name +slot-unbound+) constants))
 192               ((constantp initform)
 193                (push (cons name (eval initform)) constants)
 194                (when (eq flag ':unsupplied) (setq flag ':constants)))
 195               (t
 196                (push (cons name +slot-unbound+) constants)
 197                (setq flag t)))))
 198     (let* ((constants-alist (sort constants #'(lambda (x y)
 199                                                 (memq (car y)
 200                                                       (memq (car x) layout)))))
 201            (constants-list (mapcar #'cdr constants-alist)))
 202     (values constants-list flag))))
 203
 204 ;;; This takes a class and a list of initarg-names, and returns an alist
 205 ;;; indicating the positions of the slots those initargs may fill. The
 206 ;;; order of the initarg-names argument is important of course, since we
 207 ;;; have to respect the rules about the leftmost initarg that fills a slot
 208 ;;; having precedence. This function allows initarg names to appear twice
 209 ;;; in the list, it only considers the first appearance.
 210 (defun compute-initarg-positions (class initarg-names)
 211   (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
 212          (positions
 213            (loop for slot-name in layout
 214                  for position from 0
 215                  collect (cons slot-name position)))
 216          (slot-initargs
 217            (mapcar #'(lambda (slotd)
 218                        (list (slot-definition-initargs slotd)
 219                              (or (cdr (assq (slot-definition-name slotd)
 220                                             positions))
 221                                  ':class)))
 222                    (class-slots class))))
 223     ;; Go through each of the initargs, and figure out what position
 224     ;; it fills by replacing the entries in slot-initargs it fills.
 225     (dolist (initarg initarg-names)
 226       (dolist (slot-entry slot-initargs)
 227         (let ((slot-initargs (car slot-entry)))
 228           (when (and (listp slot-initargs)
 229                      (not (null slot-initargs))
 230                      (memq initarg slot-initargs))
 231             (setf (car slot-entry) initarg)))))
 232     (let (collect)
 233       (dolist (initarg initarg-names)
 234         (let ((positions (let (collect)
 235                            (dolist (slot-entry slot-initargs)
 236                              (when (eq (car slot-entry) initarg)
 237                                (push (cadr slot-entry) collect)))
 238                            (nreverse collect))))
 239           (when positions
 240             (push (cons initarg positions) collect))))
 241       (nreverse collect))))
 242 \f
 243 ;;; The FALLBACK case allows anything. This always works, and always
 244 ;;; appears as the last of the generators for a constructor. It does a
 245 ;;; full call to make-instance.
 246 (define-constructor-code-type fallback
 247         (class name arglist supplied-initarg-names supplied-initargs)
 248   (declare (ignore name supplied-initarg-names))
 249   `(function
 250      (lambda (&rest ignore)
 251        (declare (ignore ignore))
 252        (function
 253          (sb-kernel:instance-lambda ,arglist
 254            (make-instance
 255              ',(class-name class)
 256              ,@(let (collect)
 257                  (loop for tail on supplied-initargs by #'cddr
 258                        do (push `',(car tail) collect)
 259                           (push (cadr tail) collect))
 260                  (nreverse collect))))))))
 261 \f
 262 ;;; The GENERAL case allows:
 263 ;;;   constant, unsupplied or non-constant initforms
 264 ;;;   constant or non-constant default initargs
 265 ;;;   supplied initargs
 266 ;;;   slot-filling initargs
 267 ;;;   :after methods on shared-initialize and initialize-instance
 268 (define-constructor-code-type general
 269         (class name arglist supplied-initarg-names supplied-initargs)
 270   (declare (ignore name))
 271   (let ((raw-allocator (raw-instance-allocator class))
 272         (slots-fetcher (slots-fetcher class)))
 273     `(function
 274        (lambda (class .wrapper. defaults init shared)
 275          (multiple-value-bind (.constants.
 276                                .constant-initargs.
 277                                .initfns-initargs-and-positions.
 278                                .supplied-initarg-positions.
 279                                .shared-initfns.
 280                                .initfns.)
 281              (general-generator-internal class
 282                                          defaults
 283                                          init
 284                                          shared
 285                                          ',supplied-initarg-names
 286                                          ',supplied-initargs)
 287            .supplied-initarg-positions.
 288            (when (and .constants.
 289                       (null (non-pcl-or-after-initialize-instance-methods-p
 290                               init))
 291                       (null (non-pcl-or-after-shared-initialize-methods-p
 292                               shared)))
 293              (function
 294                (sb-kernel:instance-lambda ,arglist
 295                  (declare #.*optimize-speed*)
 296                  (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 297                         (.slots. (,slots-fetcher .instance.))
 298                         (.positions. .supplied-initarg-positions.)
 299                         (.initargs. .constant-initargs.))
 300                    .positions.
 301
 302                    (dolist (entry .initfns-initargs-and-positions.)
 303                      (let ((val (funcall (car entry)))
 304                            (initarg (cadr entry)))
 305                        (when initarg
 306                          (push val .initargs.)
 307                          (push initarg .initargs.))
 308                        (dolist (pos (cddr entry))
 309                          (setf (clos-slots-ref .slots. pos) val))))
 310
 311                    ,@(let (collect)
 312                        (doplist (initarg value) supplied-initargs
 313                          (unless (constantp value)
 314                            (push `(let ((.value. ,value))
 315                                    (push .value. .initargs.)
 316                                    (push ',initarg .initargs.)
 317                                    (dolist (.p. (pop .positions.))
 318                                      (setf (clos-slots-ref .slots. .p.)
 319                                            .value.)))
 320                                  collect)))
 321                        (nreverse collect))
 322
 323                    (dolist (fn .shared-initfns.)
 324                      (apply fn .instance. t .initargs.))
 325                    (dolist (fn .initfns.)
 326                      (apply fn .instance. .initargs.))
 327
 328                    .instance.)))))))))
 329
 330 (defun general-generator-internal
 331        (class defaults init shared supplied-initarg-names supplied-initargs)
 332   (flet ((bail-out () (return-from general-generator-internal nil)))
 333     (let* ((constants (compute-constant-vector class))
 334            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 335            (initarg-positions
 336              (compute-initarg-positions class
 337                                         (append supplied-initarg-names
 338                                                 (mapcar #'car defaults))))
 339            (initfns-initargs-and-positions ())
 340            (supplied-initarg-positions ())
 341            (constant-initargs ())
 342            (used-positions ()))
 343
 344       ;; Go through each of the supplied initargs for three reasons.
 345       ;;
 346       ;;   - If it fills a class slot, bail out.
 347       ;;   - If its a constant form, fill the constant vector.
 348       ;;   - Otherwise remember the positions no two initargs
 349       ;;     will try to fill the same position, since compute
 350       ;;     initarg positions already took care of that, but
 351       ;;     we do need to know what initforms will and won't
 352       ;;     be needed.
 353       (doplist (initarg val) supplied-initargs
 354         (let ((positions (cdr (assq initarg initarg-positions))))
 355           (cond ((memq :class positions) (bail-out))
 356                 ((constantp val)
 357                  (setq val (eval val))
 358                  (push val constant-initargs)
 359                  (push initarg constant-initargs)
 360                  (dolist (pos positions) (setf (svref constants pos) val)))
 361                 (t
 362                  (push positions supplied-initarg-positions)))
 363           (setq used-positions (append positions used-positions))))
 364
 365       ;; Go through each of the default initargs, for three reasons.
 366       ;;
 367       ;;   - If it fills a class slot, bail out.
 368       ;;   - If it is a constant, and it does fill a slot, put that
 369       ;;     into the constant vector.
 370       ;;   - If it isn't a constant, record its initfn and position.
 371       (dolist (default defaults)
 372         (let* ((name (car default))
 373                (initfn (cadr default))
 374                (form (caddr default))
 375                (value ())
 376                (positions (cdr (assq name initarg-positions))))
 377           (unless (memq name supplied-initarg-names)
 378             (cond ((memq :class positions) (bail-out))
 379                   ((constantp form)
 380                    (setq value (eval form))
 381                    (push value constant-initargs)
 382                    (push name constant-initargs)
 383                    (dolist (pos positions)
 384                      (setf (svref constants pos) value)))
 385                   (t
 386                    (push (list* initfn name positions)
 387                          initfns-initargs-and-positions)))
 388             (setq used-positions (append positions used-positions)))))
 389
 390       ;; Go through each of the slot initforms:
 391       ;;
 392       ;;    - If its position has already been filled, do nothing.
 393       ;;      The initfn won't need to be called, and the slot won't
 394       ;;      need to be touched.
 395       ;;    - If it is a class slot, and has an initform, bail out.
 396       ;;    - If its a constant or unsupplied, ignore it, it is
 397       ;;      already in the constant vector.
 398       ;;    - Otherwise, record its initfn and position
 399       (dolist (slotd (class-slots class))
 400         (let* ((alloc (slot-definition-allocation slotd))
 401                (name (slot-definition-name slotd))
 402                (form (slot-definition-initform slotd))
 403                (initfn (slot-definition-initfunction slotd))
 404                (position (position name layout)))
 405           (cond ((neq alloc :instance)
 406                  (unless (null initfn)
 407                    (bail-out)))
 408                 ((member position used-positions))
 409                 ((or (constantp form)
 410                      (null initfn)))
 411                 (t
 412                  (push (list initfn nil position)
 413                        initfns-initargs-and-positions)))))
 414
 415       (values constants
 416               constant-initargs
 417               (nreverse initfns-initargs-and-positions)
 418               (nreverse supplied-initarg-positions)
 419               (mapcar #'method-function
 420                       (remove *standard-shared-initialize-method* shared))
 421               (mapcar #'method-function
 422                       (remove *standard-initialize-instance-method* init))))))
 423 \f
 424 ;;; The NO-METHODS case allows:
 425 ;;;   constant, unsupplied or non-constant initforms
 426 ;;;   constant or non-constant default initargs
 427 ;;;   supplied initargs that are arguments to constructor, or constants
 428 ;;;   slot-filling initargs
 429 (define-constructor-code-type no-methods
 430         (class name arglist supplied-initarg-names supplied-initargs)
 431   (declare (ignore name))
 432   (let ((raw-allocator (raw-instance-allocator class))
 433         (slots-fetcher (slots-fetcher class)))
 434     `(function
 435        (lambda (class .wrapper. defaults init shared)
 436          (multiple-value-bind (.constants.
 437                                .initfns-and-positions.
 438                                .supplied-initarg-positions.)
 439              (no-methods-generator-internal class
 440                                             defaults
 441                                             ',supplied-initarg-names
 442                                             ',supplied-initargs)
 443            .initfns-and-positions.
 444            .supplied-initarg-positions.
 445            (when (and .constants.
 446                       (null (non-pcl-initialize-instance-methods-p init))
 447                       (null (non-pcl-shared-initialize-methods-p shared)))
 448              #'(sb-kernel:instance-lambda ,arglist
 449                  (declare #.*optimize-speed*)
 450                  (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 451                         (.slots. (,slots-fetcher .instance.))
 452                         (.positions. .supplied-initarg-positions.))
 453                    .positions.
 454
 455                    (dolist (entry .initfns-and-positions.)
 456                      (let ((val (funcall (car entry))))
 457                        (dolist (pos (cdr entry))
 458                          (setf (clos-slots-ref .slots. pos) val))))
 459
 460                    ,@(let (collect)
 461                        (doplist (initarg value) supplied-initargs
 462                          (unless (constantp value)
 463                            (push
 464                              `(let ((.value. ,value))
 465                                 (dolist (.p. (pop .positions.))
 466                                   (setf (clos-slots-ref .slots. .p.)
 467                                         .value.)))
 468                              collect)))
 469                        (nreverse collect))
 470
 471                    .instance.))))))))
 472
 473 (defun no-methods-generator-internal
 474        (class defaults supplied-initarg-names supplied-initargs)
 475   (flet ((bail-out () (return-from no-methods-generator-internal nil)))
 476     (let* ((constants   (compute-constant-vector class))
 477            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 478            (initarg-positions
 479              (compute-initarg-positions class
 480                                         (append supplied-initarg-names
 481                                                 (mapcar #'car defaults))))
 482            (initfns-and-positions ())
 483            (supplied-initarg-positions ())
 484            (used-positions ()))
 485
 486       ;; Go through each of the supplied initargs for three reasons.
 487       ;;
 488       ;;   - If it fills a class slot, bail out.
 489       ;;   - If its a constant form, fill the constant vector.
 490       ;;   - Otherwise remember the positions, no two initargs
 491       ;;     will try to fill the same position, since compute
 492       ;;     initarg positions already took care of that, but
 493       ;;     we do need to know what initforms will and won't
 494       ;;     be needed.
 495       (doplist (initarg val) supplied-initargs
 496         (let ((positions (cdr (assq initarg initarg-positions))))
 497           (cond ((memq :class positions) (bail-out))
 498                 ((constantp val)
 499                  (setq val (eval val))
 500                  (dolist (pos positions)
 501                    (setf (svref constants pos) val)))
 502                 (t
 503                  (push positions supplied-initarg-positions)))
 504           (setq used-positions (append positions used-positions))))
 505
 506       ;; Go through each of the default initargs, for three reasons.
 507       ;;
 508       ;;   - If it fills a class slot, bail out.
 509       ;;   - If it is a constant, and it does fill a slot, put that
 510       ;;     into the constant vector.
 511       ;;   - If it isn't a constant, record its initfn and position.
 512       (dolist (default defaults)
 513         (let* ((name (car default))
 514                (initfn (cadr default))
 515                (form (caddr default))
 516                (value ())
 517                (positions (cdr (assq name initarg-positions))))
 518           (unless (memq name supplied-initarg-names)
 519             (cond ((memq :class positions) (bail-out))
 520                   ((constantp form)
 521                    (setq value (eval form))
 522                    (dolist (pos positions)
 523                      (setf (svref constants pos) value)))
 524                   (t
 525                    (push (cons initfn positions)
 526                          initfns-and-positions)))
 527             (setq used-positions (append positions used-positions)))))
 528
 529       ;; Go through each of the slot initforms:
 530       ;;
 531       ;;    - If its position has already been filled, do nothing.
 532       ;;      The initfn won't need to be called, and the slot won't
 533       ;;      need to be touched.
 534       ;;    - If it is a class slot, and has an initform, bail out.
 535       ;;    - If its a constant or unsupplied, do nothing, we know
 536       ;;      that it is already in the constant vector.
 537       ;;    - Otherwise, record its initfn and position
 538       (dolist (slotd (class-slots class))
 539         (let* ((alloc (slot-definition-allocation slotd))
 540                (name (slot-definition-name slotd))
 541                (form (slot-definition-initform slotd))
 542                (initfn (slot-definition-initfunction slotd))
 543                (position (position name layout)))
 544           (cond ((neq alloc :instance)
 545                  (unless (null initfn)
 546                    (bail-out)))
 547                 ((member position used-positions))
 548                 ((or (constantp form)
 549                      (null initfn)))
 550                 (t
 551                  (push (list initfn position) initfns-and-positions)))))
 552
 553       (values constants
 554               (nreverse initfns-and-positions)
 555               (nreverse supplied-initarg-positions)))))
 556 \f
 557 ;;; The SIMPLE-SLOTS case allows:
 558 ;;;   constant or unsupplied initforms
 559 ;;;   constant default initargs
 560 ;;;   supplied initargs
 561 ;;;   slot filling initargs
 562 (define-constructor-code-type simple-slots
 563         (class name arglist supplied-initarg-names supplied-initargs)
 564   (declare (ignore name))
 565   (let ((raw-allocator (raw-instance-allocator class))
 566         (slots-fetcher (slots-fetcher class)))
 567     `(function
 568        (lambda (class .wrapper. defaults init shared)
 569          (when (and (null (non-pcl-initialize-instance-methods-p init))
 570                     (null (non-pcl-shared-initialize-methods-p shared)))
 571            (multiple-value-bind (.constants. .supplied-initarg-positions.)
 572                (simple-slots-generator-internal class
 573                                                 defaults
 574                                                 ',supplied-initarg-names
 575                                                 ',supplied-initargs)
 576              (when .constants.
 577                (function
 578                  (sb-kernel:instance-lambda ,arglist
 579                    (declare #.*optimize-speed*)
 580                    (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 581                           (.slots. (,slots-fetcher .instance.))
 582                           (.positions. .supplied-initarg-positions.))
 583                      .positions.
 584
 585                      ,@(let (collect)
 586                          (doplist (initarg value) supplied-initargs
 587                            (unless (constantp value)
 588                              (push
 589                                `(let ((.value. ,value))
 590                                   (dolist (.p. (pop .positions.))
 591                                     (setf (clos-slots-ref .slots. .p.)
 592                                           .value.)))
 593                                collect)))
 594                          (nreverse collect))
 595
 596                      .instance.))))))))))
 597
 598 (defun simple-slots-generator-internal
 599        (class defaults supplied-initarg-names supplied-initargs)
 600   (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
 601     (let* ((constants (compute-constant-vector class))
 602            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 603            (initarg-positions
 604              (compute-initarg-positions class
 605                                         (append supplied-initarg-names
 606                                                 (mapcar #'car defaults))))
 607            (supplied-initarg-positions ())
 608            (used-positions ()))
 609
 610       ;; Go through each of the supplied initargs for three reasons.
 611       ;;
 612       ;;   - If it fills a class slot, bail out.
 613       ;;   - If its a constant form, fill the constant vector.
 614       ;;   - Otherwise remember the positions, no two initargs
 615       ;;     will try to fill the same position, since compute
 616       ;;     initarg positions already took care of that, but
 617       ;;     we do need to know what initforms will and won't
 618       ;;     be needed.
 619       (doplist (initarg val) supplied-initargs
 620         (let ((positions (cdr (assq initarg initarg-positions))))
 621           (cond ((memq :class positions) (bail-out))
 622                 ((constantp val)
 623                  (setq val (eval val))
 624                  (dolist (pos positions)
 625                    (setf (svref constants pos) val)))
 626                 (t
 627                  (push positions supplied-initarg-positions)))
 628           (setq used-positions (append used-positions positions))))
 629
 630       ;; Go through each of the default initargs for three reasons.
 631       ;;
 632       ;;   - If it isn't a constant form, bail out.
 633       ;;   - If it fills a class slot, bail out.
 634       ;;   - If it is a constant, and it does fill a slot, put that
 635       ;;     into the constant vector.
 636       (dolist (default defaults)
 637         (let* ((name (car default))
 638                (form (caddr default))
 639                (value ())
 640                (positions (cdr (assq name initarg-positions))))
 641           (unless (memq name supplied-initarg-names)
 642             (cond ((memq :class positions) (bail-out))
 643                   ((not (constantp form))
 644                    (bail-out))
 645                   (t
 646                    (setq value (eval form))
 647                    (dolist (pos positions)
 648                      (setf (svref constants pos) value)))))))
 649
 650       ;; Go through each of the slot initforms:
 651       ;;
 652       ;;    - If its position has already been filled, do nothing.
 653       ;;      The initfn won't need to be called, and the slot won't
 654       ;;      need to be touched, we are OK.
 655       ;;    - If it has a non-constant initform, bail-out. This
 656       ;;      case doesn't handle those.
 657       ;;    - If it has a constant or unsupplied initform we don't
 658       ;;      really need to do anything, the value is in the
 659       ;;      constants vector.
 660       (dolist (slotd (class-slots class))
 661         (let* ((alloc (slot-definition-allocation slotd))
 662                (name (slot-definition-name slotd))
 663                (form (slot-definition-initform slotd))
 664                (initfn (slot-definition-initfunction slotd))
 665                (position (position name layout)))
 666           (cond ((neq alloc :instance)
 667                  (unless (null initfn)
 668                    (bail-out)))
 669                 ((member position used-positions))
 670                 ((or (constantp form)
 671                      (null initfn)))
 672                 (t
 673                  (bail-out)))))
 674
 675       (values constants (nreverse supplied-initarg-positions)))))