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