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