src/pcl/construct.lisp

   1 ;;;; This file defines the defconstructor and other make-instance optimization
   2 ;;;; mechanisms.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6
   7 ;;;; This software is derived from software originally released by Xerox
   8 ;;;; Corporation. Copyright and release statements follow. Later modifications
   9 ;;;; to the software are in the public domain and are provided with
  10 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  11 ;;;; information.
  12
  13 ;;;; copyright information from original PCL sources:
  14 ;;;;
  15 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  16 ;;;; All rights reserved.
  17 ;;;;
  18 ;;;; Use and copying of this software and preparation of derivative works based
  19 ;;;; upon this software are permitted. Any distribution of this software or
  20 ;;;; derivative works must comply with all applicable United States export
  21 ;;;; control laws.
  22 ;;;;
  23 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  24 ;;;; warranty about the software, its performance or its conformity to any
  25 ;;;; specification.
  26
  27 (in-package "SB-PCL")
  28
  29 (sb-int:file-comment
  30   "$Header$")
  31 \f
  32 ;;; defconstructor is used to define special purpose functions which just
  33 ;;; call make-instance with a symbol as the first argument. The semantics
  34 ;;; of defconstructor is that it is equivalent to defining a function which
  35 ;;; just calls make-instance. The purpose of defconstructor is to provide
  36 ;;; PCL with a way of noticing these calls to make-instance so that it can
  37 ;;; optimize them. Specific ports of PCL could just have their compiler
  38 ;;; spot these calls to make-instance and then call this code. Having the
  39 ;;; special defconstructor facility is the best we can do portably.
  40 ;;;
  41 ;;; A call to defconstructor like:
  42 ;;;
  43 ;;;  (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
  44 ;;;
  45 ;;; Is equivalent to a defun like:
  46 ;;;
  47 ;;;  (defun make-foo (a b &rest r)
  48 ;;;    (make-instance 'foo 'a a ':mumble b 'baz r))
  49 ;;;
  50 ;;; Calls like the following are also legal:
  51 ;;;
  52 ;;;  (defconstructor make-foo foo ())
  53 ;;;  (defconstructor make-bar bar () :x *x* :y *y*)
  54 ;;;  (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
  55 ;;;
  56 ;;; The general idea of this implementation is that the expansion of the
  57 ;;; defconstructor form includes the creation of closure generators which
  58 ;;; can be called to create constructor code for the class. The ways that
  59 ;;; a constructor can be optimized depends not only on the defconstructor
  60 ;;; form, but also on the state of the class and the generic functions in
  61 ;;; the initialization protocol. Because of this, the determination of the
  62 ;;; form of constructor code to be used is a two part process.
  63 ;;;
  64 ;;; At compile time, make-constructor-code-generators looks at the actual
  65 ;;; defconstructor form and makes a list of appropriate constructor code
  66 ;;; generators. All that is really taken into account here is whether
  67 ;;; any initargs are supplied in the call to make-instance, and whether
  68 ;;; any of those are constant.
  69 ;;;
  70 ;;; At constructor code generation time (see note about lazy evaluation)
  71 ;;; compute-constructor-code calls each of the constructor code generators
  72 ;;; to try to get code for this constructor. Each generator looks at the
  73 ;;; state of the class and initialization protocol generic functions and
  74 ;;; decides whether its type of code is appropriate. This depends on things
  75 ;;; like whether there are any applicable methods on initialize-instance,
  76 ;;; whether class slots are affected by initialization etc.
  77 ;;;
  78 ;;; Constructor objects are funcallable instances, the protocol followed to
  79 ;;; to compute the constructor code for them is quite similar to the protocol
  80 ;;; followed to compute the discriminator code for a generic function. When
  81 ;;; the constructor is first loaded, we install as its code a function which
  82 ;;; will compute the actual constructor code the first time it is called.
  83 ;;;
  84 ;;; If there is an update to the class structure which might invalidate the
  85 ;;; optimized constructor, the special lazy constructor installer is put back
  86 ;;; so that it can compute the appropriate constructor when it is called.
  87 ;;; This is the same kind of lazy evaluation update strategy used elswhere
  88 ;;; in PCL.
  89 ;;;
  90 ;;; To allow for flexibility in the PCL implementation and to allow PCL users
  91 ;;; to specialize this constructor facility for their own metaclasses, there
  92 ;;; is an internal protocol followed by the code which loads and installs
  93 ;;; the constructors. This is documented in the comments in the code.
  94 ;;;
  95 ;;; This code is also designed so that one of its levels, can be used to
  96 ;;; implement optimization of calls to make-instance which can't go through
  97 ;;; the defconstructor facility. This has not been implemented yet, but the
  98 ;;; hooks are there.
  99
 100 (defmacro defconstructor
 101           (name class lambda-list &rest initialization-arguments)
 102   (expand-defconstructor class
 103                          name
 104                          lambda-list
 105                          (copy-list initialization-arguments)))
 106
 107 (defun expand-defconstructor (class-name name lambda-list supplied-initargs)
 108   (let ((class (find-class class-name nil))
 109         (supplied-initarg-names
 110           (gathering1 (collecting)
 111             (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
 112               (gather1 name)))))
 113     (when (null class)
 114       (error "defconstructor form being compiled (or evaluated) before~@
 115               class ~S is defined."
 116              class-name))
 117     `(progn
 118        ;; comments from PCL code back when it was portable:
 119        ;;   In order to avoid undefined function warnings, we want to
 120        ;;   tell the compile time environment that a function with this
 121        ;;   name and this argument list has been defined. The portable
 122        ;;   way to do this is with defun:
 123        ;;   #-cmu (declaim (notinline ,name))
 124        ;;   #-cmu
 125        ;;   (defun ,name ,lambda-list
 126        ;;     (declare (ignore ,@(extract-parameters lambda-list)))
 127        ;;     (error "Constructor ~S not loaded." ',name))
 128        ;;   But the derived result type for the above is wrong under CMU CL.
 129        ;;   So instead:
 130        (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
 131                        ,name))
 132        ,(make-top-level-form `(defconstructor ,name)
 133                              '(load eval)
 134           `(load-constructor
 135              ',class-name
 136              ',(class-name (class-of class))
 137              ',name
 138              ',supplied-initarg-names
 139              ;; make-constructor-code-generators is called to return a list
 140              ;; of constructor code generators. The actual interpretation
 141              ;; of this list is left to compute-constructor-code, but the
 142              ;; general idea is that it should be an plist where the keys
 143              ;; name a kind of constructor code and the values are generator
 144              ;; functions which return the actual constructor code. The
 145              ;; constructor code is usually a closures over the arguments
 146              ;; to the generator.
 147              ,(make-constructor-code-generators class
 148                                                 name
 149                                                 lambda-list
 150                                                 supplied-initarg-names
 151                                                 supplied-initargs))))))
 152
 153 (defun load-constructor (class-name metaclass-name constructor-name
 154                          supplied-initarg-names code-generators)
 155   (let ((class (find-class class-name nil)))
 156     (cond ((null class)
 157            (error "defconstructor form being loaded (or evaluated) before~@
 158                    class ~S is defined."
 159                   class-name))
 160           ((neq (class-name (class-of class)) metaclass-name)
 161            (error "When defconstructor ~S was compiled, the metaclass of the~@
 162                    class ~S was ~S. The metaclass is now ~S.~@
 163                    The constructor must be recompiled."
 164                   constructor-name
 165                   class-name
 166                   metaclass-name
 167                   (class-name (class-of class))))
 168           (t
 169            (load-constructor-internal class
 170                                       constructor-name
 171                                       supplied-initarg-names
 172                                       code-generators)
 173            constructor-name))))
 174
 175 ;;; The actual constructor objects.
 176 (defclass constructor (funcallable-standard-object)
 177      ((class                                    ;The class with which this
 178         :initarg :class                         ;constructor is associated.
 179         :reader constructor-class)              ;The actual class object,
 180                                                 ;not the class name.
 181
 182       (name                                     ;The name of this constructor.
 183         :initform nil                           ;This is the symbol in whose
 184         :initarg :name                          ;function cell the constructor
 185         :reader constructor-name)               ;usually sits. Of course, this
 186                                                 ;is optional. defconstructor
 187                                                 ;makes named constructors, but
 188                                                 ;it is possible to manipulate
 189                                                 ;anonymous constructors also.
 190
 191       (code-type                                ;The type of code currently in
 192         :initform nil                           ;use by this constructor. This
 193         :accessor constructor-code-type)        ;is mostly for debugging and
 194                                                 ;analysis purposes.
 195                                                 ;The lazy installer sets this
 196                                                 ;to LAZY. The most basic and
 197                                                 ;least optimized type of code
 198                                                 ;is called FALLBACK.
 199
 200       (supplied-initarg-names                   ;The names of the initargs this
 201         :initarg :supplied-initarg-names        ;constructor supplies when it
 202         :reader                                 ;"calls" make-instance.
 203            constructor-supplied-initarg-names)  ;
 204
 205       (code-generators                          ;Generators for the different
 206         :initarg :code-generators               ;types of code this constructor
 207         :reader constructor-code-generators))   ;could use.
 208   (:metaclass funcallable-standard-class))
 209
 210 ;;; Because the value in the code-type slot should always correspond to the
 211 ;;; funcallable-instance-function of the constructor, this function should
 212 ;;; always be used to set the both at the same time.
 213 (defun set-constructor-code (constructor code type)
 214   (set-funcallable-instance-function constructor code)
 215   (set-function-name constructor (constructor-name constructor))
 216   (setf (constructor-code-type constructor) type))
 217
 218 (defmethod describe-object ((constructor constructor) stream)
 219   (format stream
 220           "~S is a constructor for the class ~S.~%~
 221             The current code type is ~S.~%~
 222             Other possible code types are ~S."
 223           constructor (constructor-class constructor)
 224           (constructor-code-type constructor)
 225           (gathering1 (collecting)
 226             (doplist (key val) (constructor-code-generators constructor)
 227               (gather1 key)))))
 228
 229 ;;; I am not in a hairy enough mood to make this implementation be metacircular
 230 ;;; enough that it can support a defconstructor for constructor objects.
 231 (defun make-constructor (class name supplied-initarg-names code-generators)
 232   (make-instance 'constructor
 233                  :class class
 234                  :name name
 235                  :supplied-initarg-names supplied-initarg-names
 236                  :code-generators code-generators))
 237
 238 ; This definition actually appears in std-class.lisp.
 239 ;(defmethod class-constructors ((class std-class))
 240 ;  (with-slots (plist) class (getf plist 'constructors)))
 241
 242 (defmethod add-constructor ((class slot-class)
 243                             (constructor constructor))
 244   (with-slots (plist) class
 245     (pushnew constructor (getf plist 'constructors))))
 246
 247 (defmethod remove-constructor ((class slot-class)
 248                                (constructor constructor))
 249   (with-slots (plist) class
 250     (setf (getf plist 'constructors)
 251           (delete constructor (getf plist 'constructors)))))
 252
 253 (defmethod get-constructor ((class slot-class) name &optional (error-p t))
 254   (or (dolist (c (class-constructors class))
 255         (when (eq (constructor-name c) name) (return c)))
 256       (if error-p
 257           (error "Couldn't find a constructor with name ~S for class ~S."
 258                  name class)
 259           ())))
 260
 261 ;;; This is called to actually load a defconstructor constructor. It must
 262 ;;; install the lazy installer in the function cell of the constructor name,
 263 ;;; and also add this constructor to the list of constructors the class has.
 264 (defmethod load-constructor-internal
 265            ((class slot-class) name initargs generators)
 266   (let ((constructor (make-constructor class name initargs generators))
 267         (old (get-constructor class name nil)))
 268     (when old (remove-constructor class old))
 269     (install-lazy-constructor-installer constructor)
 270     (add-constructor class constructor)
 271     (setf (gdefinition name) constructor)))
 272
 273 (defmethod install-lazy-constructor-installer ((constructor constructor))
 274   (let ((class (constructor-class constructor)))
 275     (set-constructor-code constructor
 276                           #'(sb-kernel:instance-lambda (&rest args)
 277                               (multiple-value-bind (code type)
 278                                   (compute-constructor-code class constructor)
 279                                 (set-constructor-code constructor code type)
 280                                 (apply constructor args)))
 281                           'lazy)))
 282
 283 ;;; The interface to keeping the constructors updated.
 284 ;;;
 285 ;;; add-method and remove-method (for standard-generic-function and -method),
 286 ;;; promise to call maybe-update-constructors on the generic function and
 287 ;;; the method.
 288 ;;;
 289 ;;; The class update code promises to call update-constructors whenever the
 290 ;;; class is changed. That is, whenever the supers, slots or options change.
 291 ;;; If user defined classes of constructor needs to be updated in more than
 292 ;;; these circumstances, they should use the dependent updating mechanism to
 293 ;;; make sure update-constructors is called.
 294 ;;;
 295 ;;; Bootstrapping concerns force the definitions of maybe-update-constructors
 296 ;;; and update-constructors to be in the file std-class. For clarity, they
 297 ;;; also appear below. Be sure to keep the definition here and there in sync.
 298 ;(defvar *initialization-generic-functions*
 299 ;        (list #'make-instance
 300 ;              #'default-initargs
 301 ;              #'allocate-instance
 302 ;              #'initialize-instance
 303 ;              #'shared-initialize))
 304 ;
 305 ;(defmethod maybe-update-constructors
 306 ;          ((generic-function generic-function)
 307 ;           (method method))
 308 ;  (when (memq generic-function *initialization-generic-functions*)
 309 ;    (labels ((recurse (class)
 310 ;              (update-constructors class)
 311 ;              (dolist (subclass (class-direct-subclasses class))
 312 ;                (recurse subclass))))
 313 ;      (when (classp (car (method-specializers method)))
 314 ;       (recurse (car (method-specializers method)))))))
 315 ;
 316 ;(defmethod update-constructors ((class slot-class))
 317 ;  (dolist (cons (class-constructors class))
 318 ;    (install-lazy-constructor-installer cons)))
 319 ;
 320 ;(defmethod update-constructors ((class class))
 321 ;  ())
 322 \f
 323 ;;; Here is the actual smarts for making the code generators and then trying
 324 ;;; each generator to get constructor code. This extensible mechanism allows
 325 ;;; new kinds of constructor code types to be added. A programmer defining a
 326 ;;; specialization of the constructor class can either use this mechanism to
 327 ;;; define new code types, or can override this mechanism by overriding the
 328 ;;; methods on make-constructor-code-generators and compute-constructor-code.
 329 ;;;
 330 ;;; The function defined by define-constructor-code-type will receive the
 331 ;;; class object, and the 4 original arguments to defconstructor. It can
 332 ;;; return a constructor code generator, or return nil if this type of code
 333 ;;; is determined to not be appropriate after looking at the defconstructor
 334 ;;; arguments.
 335 ;;;
 336 ;;; When compute-constructor-code is called, it first performs basic checks
 337 ;;; to make sure that the basic assumptions common to all the code types are
 338 ;;; valid. (For details see method definition). If any of the tests fail,
 339 ;;; the fallback constructor code type is used. If none of the tests fail,
 340 ;;; the constructor code generators are called in order. They receive 5
 341 ;;; arguments:
 342 ;;;
 343 ;;;   CLASS     the class the constructor is making instances of
 344 ;;;   WRAPPER      that class's wrapper
 345 ;;;   DEFAULTS     the result of calling class-default-initargs on class
 346 ;;;   INITIALIZE   the applicable methods on initialize-instance
 347 ;;;   SHARED       the applicable methosd on shared-initialize
 348 ;;;
 349 ;;; The first code generator to return code is used. The code generators are
 350 ;;; called in reverse order of definition, so define-constructor-code-type
 351 ;;; forms which define better code should appear after ones that define less
 352 ;;; good code. The fallback code type appears first. Note that redefining a
 353 ;;; code type does not change its position in the list. To do that,  define
 354 ;;; a new type at the end with the behavior.
 355
 356 (defvar *constructor-code-types* ())
 357
 358 (defmacro define-constructor-code-type (type arglist &body body)
 359   (let ((fn-name (intern (format nil
 360                                  "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
 361                                  (package-name (symbol-package type))
 362                                  (symbol-name type))
 363                          *pcl-package*)))
 364     `(progn
 365        (defun ,fn-name ,arglist .,body)
 366        (load-define-constructor-code-type ',type ',fn-name))))
 367
 368 (defun load-define-constructor-code-type (type generator)
 369   (let ((old-entry (assq type *constructor-code-types*)))
 370     (if old-entry
 371         (setf (cadr old-entry) generator)
 372         (push (list type generator) *constructor-code-types*))
 373     type))
 374
 375 (defmethod make-constructor-code-generators
 376            ((class slot-class)
 377             name lambda-list supplied-initarg-names supplied-initargs)
 378   (cons 'list
 379         (gathering1 (collecting)
 380           (dolist (entry *constructor-code-types*)
 381             (let ((generator
 382                     (funcall (cadr entry) class name lambda-list
 383                                           supplied-initarg-names
 384                                           supplied-initargs)))
 385               (when generator
 386                 (gather1 `',(car entry))
 387                 (gather1 generator)))))))
 388
 389 (defmethod compute-constructor-code ((class slot-class)
 390                                      (constructor constructor))
 391   (let* ((proto (class-prototype class))
 392          (wrapper (class-wrapper class))
 393          (defaults (class-default-initargs class))
 394          (make
 395            (compute-applicable-methods (gdefinition 'make-instance) (list class)))
 396          (supplied-initarg-names
 397            (constructor-supplied-initarg-names constructor))
 398          (default
 399            (compute-applicable-methods (gdefinition 'default-initargs)
 400                                        (list class supplied-initarg-names))) ;?
 401          (allocate
 402            (compute-applicable-methods (gdefinition 'allocate-instance)
 403                                        (list class)))
 404          (initialize
 405            (compute-applicable-methods (gdefinition 'initialize-instance)
 406                                        (list proto)))
 407          (shared
 408            (compute-applicable-methods (gdefinition 'shared-initialize)
 409                                        (list proto t)))
 410          (code-generators
 411            (constructor-code-generators constructor)))
 412     (flet ((call-code-generator (generator)
 413              (when (null generator)
 414                (unless (setq generator (getf code-generators 'fallback))
 415                  (error "No FALLBACK generator?")))
 416              (funcall generator class wrapper defaults initialize shared)))
 417       (if (or (cdr make)
 418               (cdr default)
 419               (cdr allocate)
 420               (not (check-initargs-1 class
 421                                      supplied-initarg-names
 422                                      (append initialize shared)
 423                                      nil nil)))
 424           ;; These are basic shared assumptions, if one of the
 425           ;; has been violated, we have to resort to the fallback
 426           ;; case. Any of these assumptions could be moved out
 427           ;; of here and into the individual code types if there
 428           ;; was a need to do so.
 429           (values (call-code-generator nil) 'fallback)
 430           ;; Otherwise try all the generators until one produces
 431           ;; code for us.
 432           (doplist (type generator) code-generators
 433             (let ((code (call-code-generator generator)))
 434               (when code (return (values code type)))))))))
 435
 436 ;;; The facilities are useful for debugging, and to measure the performance
 437 ;;; boost from constructors.
 438 ;;;
 439 ;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional
 440
 441 (defun map-constructors (fn)
 442   (let ((nclasses 0)
 443         (nconstructors 0))
 444     (labels ((recurse (class)
 445                (incf nclasses)
 446                (dolist (constructor (class-constructors class))
 447                  (incf nconstructors)
 448                  (funcall fn constructor))
 449                (dolist (subclass (class-direct-subclasses class))
 450                  (recurse subclass))))
 451       (recurse (find-class 't))
 452       (values nclasses nconstructors))))
 453
 454 (defun reset-constructors ()
 455   (multiple-value-bind (nclass ncons)
 456       (map-constructors #'install-lazy-constructor-installer )
 457     (format t "~&~D classes, ~D constructors." nclass ncons)))
 458
 459 (defun disable-constructors ()
 460   (multiple-value-bind (nclass ncons)
 461       (map-constructors
 462         #'(lambda (c)
 463             (let ((gen (getf (constructor-code-generators c) 'fallback)))
 464               (if (null gen)
 465                   (error "No fallback constructor for ~S." c)
 466                   (set-constructor-code c
 467                                         (funcall gen
 468                                                  (constructor-class c)
 469                                                  () () () ())
 470                                         'fallback)))))
 471     (format t "~&~D classes, ~D constructors." nclass ncons)))
 472
 473 (defun enable-constructors ()
 474   (reset-constructors))
 475 \f
 476 ;;; helper functions and utilities that are shared by all of the code types
 477 ;;; and by the main compute-constructor-code method as well
 478
 479 (defvar *standard-initialize-instance-method*
 480         (get-method #'initialize-instance
 481                     ()
 482                     (list *the-class-slot-object*)))
 483
 484 (defvar *standard-shared-initialize-method*
 485         (get-method #'shared-initialize
 486                     ()
 487                     (list *the-class-slot-object* *the-class-t*)))
 488
 489 (defun non-pcl-initialize-instance-methods-p (methods)
 490   (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
 491             methods))
 492
 493 (defun non-pcl-shared-initialize-methods-p (methods)
 494   (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
 495             methods))
 496
 497 (defun non-pcl-or-after-initialize-instance-methods-p (methods)
 498   (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
 499                               (equal '(:after) (method-qualifiers m))))
 500             methods))
 501
 502 (defun non-pcl-or-after-shared-initialize-methods-p (methods)
 503   (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
 504                               (equal '(:after) (method-qualifiers m))))
 505             methods))
 506
 507 ;;; This returns two values. The first is a vector which can be used as the
 508 ;;; initial value of the slots vector for the instance. The second is a symbol
 509 ;;; describing the initforms this class has.
 510 ;;;
 511 ;;;  If the first value is:
 512 ;;;
 513 ;;;    :UNSUPPLIED    no slot has an initform
 514 ;;;    :CONSTANTS     all slots have either a constant initform
 515 ;;;                   or no initform at all
 516 ;;;    T              there is at least one non-constant initform
 517 (defun compute-constant-vector (class)
 518   ;;(declare (values constants flag))
 519   (let* ((wrapper (class-wrapper class))
 520          (layout (wrapper-instance-slots-layout wrapper))
 521          (flag :unsupplied)
 522          (constants ()))
 523     (dolist (slotd (class-slots class))
 524       (let ((name (slot-definition-name slotd))
 525             (initform (slot-definition-initform slotd))
 526             (initfn (slot-definition-initfunction slotd)))
 527         (cond ((null (memq name layout)))
 528               ((null initfn)
 529                (push (cons name *slot-unbound*) constants))
 530               ((constantp initform)
 531                (push (cons name (eval initform)) constants)
 532                (when (eq flag ':unsupplied) (setq flag ':constants)))
 533               (t
 534                (push (cons name *slot-unbound*) constants)
 535                (setq flag 't)))))
 536     (let* ((constants-alist (sort constants #'(lambda (x y)
 537                                                 (memq (car y)
 538                                                       (memq (car x) layout)))))
 539            (constants-list (mapcar #'cdr constants-alist)))
 540     (values constants-list flag))))
 541
 542 ;;; This takes a class and a list of initarg-names, and returns an alist
 543 ;;; indicating the positions of the slots those initargs may fill. The
 544 ;;; order of the initarg-names argument is important of course, since we
 545 ;;; have to respect the rules about the leftmost initarg that fills a slot
 546 ;;; having precedence. This function allows initarg names to appear twice
 547 ;;; in the list, it only considers the first appearance.
 548 (defun compute-initarg-positions (class initarg-names)
 549   (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
 550          (positions
 551            (gathering1 (collecting)
 552              (iterate ((slot-name (list-elements layout))
 553                        (position (interval :from 0)))
 554                (gather1 (cons slot-name position)))))
 555          (slot-initargs
 556            (mapcar #'(lambda (slotd)
 557                        (list (slot-definition-initargs slotd)
 558                              (or (cdr (assq (slot-definition-name slotd)
 559                                             positions))
 560                                  ':class)))
 561                    (class-slots class))))
 562     ;; Go through each of the initargs, and figure out what position
 563     ;; it fills by replacing the entries in slot-initargs it fills.
 564     (dolist (initarg initarg-names)
 565       (dolist (slot-entry slot-initargs)
 566         (let ((slot-initargs (car slot-entry)))
 567           (when (and (listp slot-initargs)
 568                      (not (null slot-initargs))
 569                      (memq initarg slot-initargs))
 570             (setf (car slot-entry) initarg)))))
 571     (gathering1 (collecting)
 572       (dolist (initarg initarg-names)
 573         (let ((positions (gathering1 (collecting)
 574                            (dolist (slot-entry slot-initargs)
 575                              (when (eq (car slot-entry) initarg)
 576                                (gather1 (cadr slot-entry)))))))
 577           (when positions
 578             (gather1 (cons initarg positions))))))))
 579 \f
 580 ;;; The FALLBACK case allows anything. This always works, and always appears
 581 ;;; as the last of the generators for a constructor. It does a full call to
 582 ;;; make-instance.
 583 (define-constructor-code-type fallback
 584         (class name arglist supplied-initarg-names supplied-initargs)
 585   (declare (ignore name supplied-initarg-names))
 586   `(function
 587      (lambda (&rest ignore)
 588        (declare (ignore ignore))
 589        (function
 590          (sb-kernel:instance-lambda ,arglist
 591            (make-instance
 592              ',(class-name class)
 593              ,@(gathering1 (collecting)
 594                  (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
 595                    (gather1 `',(car tail))
 596                    (gather1 (cadr tail))))))))))
 597 \f
 598 ;;; The GENERAL case allows:
 599 ;;;   constant, unsupplied or non-constant initforms
 600 ;;;   constant or non-constant default initargs
 601 ;;;   supplied initargs
 602 ;;;   slot-filling initargs
 603 ;;;   :after methods on shared-initialize and initialize-instance
 604 (define-constructor-code-type general
 605         (class name arglist supplied-initarg-names supplied-initargs)
 606   (declare (ignore name))
 607   (let ((raw-allocator (raw-instance-allocator class))
 608         (slots-fetcher (slots-fetcher class)))
 609     `(function
 610        (lambda (class .wrapper. defaults init shared)
 611          (multiple-value-bind (.constants.
 612                                .constant-initargs.
 613                                .initfns-initargs-and-positions.
 614                                .supplied-initarg-positions.
 615                                .shared-initfns.
 616                                .initfns.)
 617              (general-generator-internal class
 618                                          defaults
 619                                          init
 620                                          shared
 621                                          ',supplied-initarg-names
 622                                          ',supplied-initargs)
 623            .supplied-initarg-positions.
 624            (when (and .constants.
 625                       (null (non-pcl-or-after-initialize-instance-methods-p
 626                               init))
 627                       (null (non-pcl-or-after-shared-initialize-methods-p
 628                               shared)))
 629              (function
 630                (sb-kernel:instance-lambda ,arglist
 631                  (declare #.*optimize-speed*)
 632                  (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 633                         (.slots. (,slots-fetcher .instance.))
 634                         (.positions. .supplied-initarg-positions.)
 635                         (.initargs. .constant-initargs.))
 636                    .positions.
 637
 638                    (dolist (entry .initfns-initargs-and-positions.)
 639                      (let ((val (funcall (car entry)))
 640                            (initarg (cadr entry)))
 641                        (when initarg
 642                          (push val .initargs.)
 643                          (push initarg .initargs.))
 644                        (dolist (pos (cddr entry))
 645                          (setf (%instance-ref .slots. pos) val))))
 646
 647                    ,@(gathering1 (collecting)
 648                        (doplist (initarg value) supplied-initargs
 649                          (unless (constantp value)
 650                            (gather1 `(let ((.value. ,value))
 651                                        (push .value. .initargs.)
 652                                        (push ',initarg .initargs.)
 653                                        (dolist (.p. (pop .positions.))
 654                                          (setf (%instance-ref .slots. .p.)
 655                                                .value.)))))))
 656
 657                    (dolist (fn .shared-initfns.)
 658                      (apply fn .instance. t .initargs.))
 659                    (dolist (fn .initfns.)
 660                      (apply fn .instance. .initargs.))
 661
 662                    .instance.)))))))))
 663
 664 (defun general-generator-internal
 665        (class defaults init shared supplied-initarg-names supplied-initargs)
 666   (flet ((bail-out () (return-from general-generator-internal nil)))
 667     (let* ((constants (compute-constant-vector class))
 668            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 669            (initarg-positions
 670              (compute-initarg-positions class
 671                                         (append supplied-initarg-names
 672                                                 (mapcar #'car defaults))))
 673            (initfns-initargs-and-positions ())
 674            (supplied-initarg-positions ())
 675            (constant-initargs ())
 676            (used-positions ()))
 677
 678       ;; Go through each of the supplied initargs for three reasons.
 679       ;;
 680       ;;   - If it fills a class slot, bail out.
 681       ;;   - If its a constant form, fill the constant vector.
 682       ;;   - Otherwise remember the positions no two initargs
 683       ;;     will try to fill the same position, since compute
 684       ;;     initarg positions already took care of that, but
 685       ;;     we do need to know what initforms will and won't
 686       ;;     be needed.
 687       (doplist (initarg val) supplied-initargs
 688         (let ((positions (cdr (assq initarg initarg-positions))))
 689           (cond ((memq :class positions) (bail-out))
 690                 ((constantp val)
 691                  (setq val (eval val))
 692                  (push val constant-initargs)
 693                  (push initarg constant-initargs)
 694                  (dolist (pos positions) (setf (svref constants pos) val)))
 695                 (t
 696                  (push positions supplied-initarg-positions)))
 697           (setq used-positions (append positions used-positions))))
 698
 699       ;; Go through each of the default initargs, for three reasons.
 700       ;;
 701       ;;   - If it fills a class slot, bail out.
 702       ;;   - If it is a constant, and it does fill a slot, put that
 703       ;;     into the constant vector.
 704       ;;   - If it isn't a constant, record its initfn and position.
 705       (dolist (default defaults)
 706         (let* ((name (car default))
 707                (initfn (cadr default))
 708                (form (caddr default))
 709                (value ())
 710                (positions (cdr (assq name initarg-positions))))
 711           (unless (memq name supplied-initarg-names)
 712             (cond ((memq :class positions) (bail-out))
 713                   ((constantp form)
 714                    (setq value (eval form))
 715                    (push value constant-initargs)
 716                    (push name constant-initargs)
 717                    (dolist (pos positions)
 718                      (setf (svref constants pos) value)))
 719                   (t
 720                    (push (list* initfn name positions)
 721                          initfns-initargs-and-positions)))
 722             (setq used-positions (append positions used-positions)))))
 723
 724       ;; Go through each of the slot initforms:
 725       ;;
 726       ;;    - If its position has already been filled, do nothing.
 727       ;;      The initfn won't need to be called, and the slot won't
 728       ;;      need to be touched.
 729       ;;    - If it is a class slot, and has an initform, bail out.
 730       ;;    - If its a constant or unsupplied, ignore it, it is
 731       ;;      already in the constant vector.
 732       ;;    - Otherwise, record its initfn and position
 733       (dolist (slotd (class-slots class))
 734         (let* ((alloc (slot-definition-allocation slotd))
 735                (name (slot-definition-name slotd))
 736                (form (slot-definition-initform slotd))
 737                (initfn (slot-definition-initfunction slotd))
 738                (position (position name layout)))
 739           (cond ((neq alloc :instance)
 740                  (unless (null initfn)
 741                    (bail-out)))
 742                 ((member position used-positions))
 743                 ((or (constantp form)
 744                      (null initfn)))
 745                 (t
 746                  (push (list initfn nil position)
 747                        initfns-initargs-and-positions)))))
 748
 749       (values constants
 750               constant-initargs
 751               (nreverse initfns-initargs-and-positions)
 752               (nreverse supplied-initarg-positions)
 753               (mapcar #'method-function
 754                       (remove *standard-shared-initialize-method* shared))
 755               (mapcar #'method-function
 756                       (remove *standard-initialize-instance-method* init))))))
 757 \f
 758 ;;; The NO-METHODS case allows:
 759 ;;;   constant, unsupplied or non-constant initforms
 760 ;;;   constant or non-constant default initargs
 761 ;;;   supplied initargs that are arguments to constructor, or constants
 762 ;;;   slot-filling initargs
 763 (define-constructor-code-type no-methods
 764         (class name arglist supplied-initarg-names supplied-initargs)
 765   (declare (ignore name))
 766   (let ((raw-allocator (raw-instance-allocator class))
 767         (slots-fetcher (slots-fetcher class)))
 768     `(function
 769        (lambda (class .wrapper. defaults init shared)
 770          (multiple-value-bind (.constants.
 771                                .initfns-and-positions.
 772                                .supplied-initarg-positions.)
 773              (no-methods-generator-internal class
 774                                             defaults
 775                                             ',supplied-initarg-names
 776                                             ',supplied-initargs)
 777            .initfns-and-positions.
 778            .supplied-initarg-positions.
 779            (when (and .constants.
 780                       (null (non-pcl-initialize-instance-methods-p init))
 781                       (null (non-pcl-shared-initialize-methods-p shared)))
 782              #'(sb-kernel:instance-lambda ,arglist
 783                  (declare #.*optimize-speed*)
 784                  (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 785                         (.slots. (,slots-fetcher .instance.))
 786                         (.positions. .supplied-initarg-positions.))
 787                    .positions.
 788
 789                    (dolist (entry .initfns-and-positions.)
 790                      (let ((val (funcall (car entry))))
 791                        (dolist (pos (cdr entry))
 792                          (setf (%instance-ref .slots. pos) val))))
 793
 794                    ,@(gathering1 (collecting)
 795                        (doplist (initarg value) supplied-initargs
 796                          (unless (constantp value)
 797                            (gather1
 798                              `(let ((.value. ,value))
 799                                 (dolist (.p. (pop .positions.))
 800                                   (setf (%instance-ref .slots. .p.) .value.)))))))
 801
 802                    .instance.))))))))
 803
 804 (defun no-methods-generator-internal
 805        (class defaults supplied-initarg-names supplied-initargs)
 806   (flet ((bail-out () (return-from no-methods-generator-internal nil)))
 807     (let* ((constants   (compute-constant-vector class))
 808            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 809            (initarg-positions
 810              (compute-initarg-positions class
 811                                         (append supplied-initarg-names
 812                                                 (mapcar #'car defaults))))
 813            (initfns-and-positions ())
 814            (supplied-initarg-positions ())
 815            (used-positions ()))
 816
 817       ;; Go through each of the supplied initargs for three reasons.
 818       ;;
 819       ;;   - If it fills a class slot, bail out.
 820       ;;   - If its a constant form, fill the constant vector.
 821       ;;   - Otherwise remember the positions, no two initargs
 822       ;;     will try to fill the same position, since compute
 823       ;;     initarg positions already took care of that, but
 824       ;;     we do need to know what initforms will and won't
 825       ;;     be needed.
 826       (doplist (initarg val) supplied-initargs
 827         (let ((positions (cdr (assq initarg initarg-positions))))
 828           (cond ((memq :class positions) (bail-out))
 829                 ((constantp val)
 830                  (setq val (eval val))
 831                  (dolist (pos positions)
 832                    (setf (svref constants pos) val)))
 833                 (t
 834                  (push positions supplied-initarg-positions)))
 835           (setq used-positions (append positions used-positions))))
 836
 837       ;; Go through each of the default initargs, for three reasons.
 838       ;;
 839       ;;   - If it fills a class slot, bail out.
 840       ;;   - If it is a constant, and it does fill a slot, put that
 841       ;;     into the constant vector.
 842       ;;   - If it isn't a constant, record its initfn and position.
 843       (dolist (default defaults)
 844         (let* ((name (car default))
 845                (initfn (cadr default))
 846                (form (caddr default))
 847                (value ())
 848                (positions (cdr (assq name initarg-positions))))
 849           (unless (memq name supplied-initarg-names)
 850             (cond ((memq :class positions) (bail-out))
 851                   ((constantp form)
 852                    (setq value (eval form))
 853                    (dolist (pos positions)
 854                      (setf (svref constants pos) value)))
 855                   (t
 856                    (push (cons initfn positions)
 857                          initfns-and-positions)))
 858             (setq used-positions (append positions used-positions)))))
 859
 860       ;; Go through each of the slot initforms:
 861       ;;
 862       ;;    - If its position has already been filled, do nothing.
 863       ;;      The initfn won't need to be called, and the slot won't
 864       ;;      need to be touched.
 865       ;;    - If it is a class slot, and has an initform, bail out.
 866       ;;    - If its a constant or unsupplied, do nothing, we know
 867       ;;      that it is already in the constant vector.
 868       ;;    - Otherwise, record its initfn and position
 869       (dolist (slotd (class-slots class))
 870         (let* ((alloc (slot-definition-allocation slotd))
 871                (name (slot-definition-name slotd))
 872                (form (slot-definition-initform slotd))
 873                (initfn (slot-definition-initfunction slotd))
 874                (position (position name layout)))
 875           (cond ((neq alloc :instance)
 876                  (unless (null initfn)
 877                    (bail-out)))
 878                 ((member position used-positions))
 879                 ((or (constantp form)
 880                      (null initfn)))
 881                 (t
 882                  (push (list initfn position) initfns-and-positions)))))
 883
 884       (values constants
 885               (nreverse initfns-and-positions)
 886               (nreverse supplied-initarg-positions)))))
 887 \f
 888 ;;; The SIMPLE-SLOTS case allows:
 889 ;;;   constant or unsupplied initforms
 890 ;;;   constant default initargs
 891 ;;;   supplied initargs
 892 ;;;   slot filling initargs
 893 (define-constructor-code-type simple-slots
 894         (class name arglist supplied-initarg-names supplied-initargs)
 895   (declare (ignore name))
 896   (let ((raw-allocator (raw-instance-allocator class))
 897         (slots-fetcher (slots-fetcher class)))
 898     `(function
 899        (lambda (class .wrapper. defaults init shared)
 900          (when (and (null (non-pcl-initialize-instance-methods-p init))
 901                     (null (non-pcl-shared-initialize-methods-p shared)))
 902            (multiple-value-bind (.constants. .supplied-initarg-positions.)
 903                (simple-slots-generator-internal class
 904                                                 defaults
 905                                                 ',supplied-initarg-names
 906                                                 ',supplied-initargs)
 907              (when .constants.
 908                (function
 909                  (sb-kernel:instance-lambda ,arglist
 910                    (declare #.*optimize-speed*)
 911                    (let* ((.instance. (,raw-allocator .wrapper. .constants.))
 912                           (.slots. (,slots-fetcher .instance.))
 913                           (.positions. .supplied-initarg-positions.))
 914                      .positions.
 915
 916                      ,@(gathering1 (collecting)
 917                          (doplist (initarg value) supplied-initargs
 918                            (unless (constantp value)
 919                              (gather1
 920                                `(let ((.value. ,value))
 921                                   (dolist (.p. (pop .positions.))
 922                                     (setf (%instance-ref .slots. .p.)
 923                                           .value.)))))))
 924
 925                      .instance.))))))))))
 926
 927 (defun simple-slots-generator-internal
 928        (class defaults supplied-initarg-names supplied-initargs)
 929   (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
 930     (let* ((constants (compute-constant-vector class))
 931            (layout (wrapper-instance-slots-layout (class-wrapper class)))
 932            (initarg-positions
 933              (compute-initarg-positions class
 934                                         (append supplied-initarg-names
 935                                                 (mapcar #'car defaults))))
 936            (supplied-initarg-positions ())
 937            (used-positions ()))
 938
 939       ;; Go through each of the supplied initargs for three reasons.
 940       ;;
 941       ;;   - If it fills a class slot, bail out.
 942       ;;   - If its a constant form, fill the constant vector.
 943       ;;   - Otherwise remember the positions, no two initargs
 944       ;;     will try to fill the same position, since compute
 945       ;;     initarg positions already took care of that, but
 946       ;;     we do need to know what initforms will and won't
 947       ;;     be needed.
 948       (doplist (initarg val) supplied-initargs
 949         (let ((positions (cdr (assq initarg initarg-positions))))
 950           (cond ((memq :class positions) (bail-out))
 951                 ((constantp val)
 952                  (setq val (eval val))
 953                  (dolist (pos positions)
 954                    (setf (svref constants pos) val)))
 955                 (t
 956                  (push positions supplied-initarg-positions)))
 957           (setq used-positions (append used-positions positions))))
 958
 959       ;; Go through each of the default initargs for three reasons.
 960       ;;
 961       ;;   - If it isn't a constant form, bail out.
 962       ;;   - If it fills a class slot, bail out.
 963       ;;   - If it is a constant, and it does fill a slot, put that
 964       ;;     into the constant vector.
 965       (dolist (default defaults)
 966         (let* ((name (car default))
 967                (form (caddr default))
 968                (value ())
 969                (positions (cdr (assq name initarg-positions))))
 970           (unless (memq name supplied-initarg-names)
 971             (cond ((memq :class positions) (bail-out))
 972                   ((not (constantp form))
 973                    (bail-out))
 974                   (t
 975                    (setq value (eval form))
 976                    (dolist (pos positions)
 977                      (setf (svref constants pos) value)))))))
 978
 979       ;; Go through each of the slot initforms:
 980       ;;
 981       ;;    - If its position has already been filled, do nothing.
 982       ;;      The initfn won't need to be called, and the slot won't
 983       ;;      need to be touched, we are OK.
 984       ;;    - If it has a non-constant initform, bail-out. This
 985       ;;      case doesn't handle those.
 986       ;;    - If it has a constant or unsupplied initform we don't
 987       ;;      really need to do anything, the value is in the
 988       ;;      constants vector.
 989       (dolist (slotd (class-slots class))
 990         (let* ((alloc (slot-definition-allocation slotd))
 991                (name (slot-definition-name slotd))
 992                (form (slot-definition-initform slotd))
 993                (initfn (slot-definition-initfunction slotd))
 994                (position (position name layout)))
 995           (cond ((neq alloc :instance)
 996                  (unless (null initfn)
 997                    (bail-out)))
 998                 ((member position used-positions))
 999                 ((or (constantp form)
1000                      (null initfn)))
1001                 (t
1002                  (bail-out)))))
1003
1004       (values constants (nreverse supplied-initarg-positions)))))
1005