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