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
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.
38 ;;; A call to defconstructor like:
40 ;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
42 ;;; Is equivalent to a defun like:
44 ;;; (defun make-foo (a b &rest r)
45 ;;; (make-instance 'foo 'a a ':mumble b 'baz r))
47 ;;; Calls like the following are also legal:
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))
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.
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.
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.
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.
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
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.
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
97 (defmacro defconstructor
98 (name class lambda-list &rest initialization-arguments)
99 (expand-defconstructor class
102 (copy-list initialization-arguments)))
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)))
111 (error "defconstructor form being compiled (or evaluated) before~@
112 class ~S is defined."
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))
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.
127 (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
129 ,(make-top-level-form `(defconstructor ,name)
133 ',(class-name (class-of class))
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
144 ,(make-constructor-code-generators class
147 supplied-initarg-names
148 supplied-initargs))))))
150 (defun load-constructor (class-name metaclass-name constructor-name
151 supplied-initarg-names code-generators)
152 (let ((class (find-class class-name nil)))
154 (error "defconstructor form being loaded (or evaluated) before~@
155 class ~S is defined."
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."
164 (class-name (class-of class))))
166 (load-constructor-internal class
168 supplied-initarg-names
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,
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.
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
192 ;The lazy installer sets this
193 ;to LAZY. The most basic and
194 ;least optimized type of code
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) ;
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))
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))
215 (defmethod describe-object ((constructor constructor) 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)
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
232 :supplied-initarg-names supplied-initarg-names
233 :code-generators code-generators))
235 ; This definition actually appears in std-class.lisp.
236 ;(defmethod class-constructors ((class std-class))
237 ; (with-slots (plist) class (getf plist 'constructors)))
239 (defmethod add-constructor ((class slot-class)
240 (constructor constructor))
241 (with-slots (plist) class
242 (pushnew constructor (getf plist 'constructors))))
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)))))
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)))
254 (error "Couldn't find a constructor with name ~S for class ~S."
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)))
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)))
280 ;;; The interface to keeping the constructors updated.
282 ;;; add-method and remove-method (for standard-generic-function and -method),
283 ;;; promise to call maybe-update-constructors on the generic function and
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.
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
298 ; #'allocate-instance
299 ; #'initialize-instance
300 ; #'shared-initialize))
302 ;(defmethod maybe-update-constructors
303 ; ((generic-function generic-function)
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)))))))
313 ;(defmethod update-constructors ((class slot-class))
314 ; (dolist (cons (class-constructors class))
315 ; (install-lazy-constructor-installer cons)))
317 ;(defmethod update-constructors ((class class))
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.
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
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
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
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.
353 (defvar *constructor-code-types* ())
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))
362 (defun ,fn-name ,arglist .,body)
363 (load-define-constructor-code-type ',type ',fn-name))))
365 (defun load-define-constructor-code-type (type generator)
366 (let ((old-entry (assq type *constructor-code-types*)))
368 (setf (cadr old-entry) generator)
369 (push (list type generator) *constructor-code-types*))
372 (defmethod make-constructor-code-generators
374 name lambda-list supplied-initarg-names supplied-initargs)
376 (gathering1 (collecting)
377 (dolist (entry *constructor-code-types*)
379 (funcall (cadr entry) class name lambda-list
380 supplied-initarg-names
383 (gather1 `',(car entry))
384 (gather1 generator)))))))
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))
392 (compute-applicable-methods (gdefinition 'make-instance) (list class)))
393 (supplied-initarg-names
394 (constructor-supplied-initarg-names constructor))
396 (compute-applicable-methods (gdefinition 'default-initargs)
397 (list class supplied-initarg-names))) ;?
399 (compute-applicable-methods (gdefinition 'allocate-instance)
402 (compute-applicable-methods (gdefinition 'initialize-instance)
405 (compute-applicable-methods (gdefinition 'shared-initialize)
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)))
417 (not (check-initargs-1 class
418 supplied-initarg-names
419 (append initialize shared)
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
429 (doplist (type generator) code-generators
430 (let ((code (call-code-generator generator)))
431 (when code (return (values code type)))))))))
433 ;;; The facilities are useful for debugging, and to measure the performance
434 ;;; boost from constructors.
436 ;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional
438 (defun map-constructors (fn)
441 (labels ((recurse (class)
443 (dolist (constructor (class-constructors class))
445 (funcall fn constructor))
446 (dolist (subclass (class-direct-subclasses class))
447 (recurse subclass))))
448 (recurse (find-class 't))
449 (values nclasses nconstructors))))
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)))
456 (defun disable-constructors ()
457 (multiple-value-bind (nclass ncons)
460 (let ((gen (getf (constructor-code-generators c) 'fallback)))
462 (error "No fallback constructor for ~S." c)
463 (set-constructor-code c
465 (constructor-class c)
468 (format t "~&~D classes, ~D constructors." nclass ncons)))
470 (defun enable-constructors ()
471 (reset-constructors))
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
476 (defvar *standard-initialize-instance-method*
477 (get-method #'initialize-instance
479 (list *the-class-slot-object*)))
481 (defvar *standard-shared-initialize-method*
482 (get-method #'shared-initialize
484 (list *the-class-slot-object* *the-class-t*)))
486 (defun non-pcl-initialize-instance-methods-p (methods)
487 (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
490 (defun non-pcl-shared-initialize-methods-p (methods)
491 (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
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))))
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))))
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.
508 ;;; If the first value is:
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))
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)))
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)))
531 (push (cons name *slot-unbound*) constants)
533 (let* ((constants-alist (sort constants #'(lambda (x y)
535 (memq (car x) layout)))))
536 (constants-list (mapcar #'cdr constants-alist)))
537 (values constants-list flag))))
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)))
548 (gathering1 (collecting)
549 (iterate ((slot-name (list-elements layout))
550 (position (interval :from 0)))
551 (gather1 (cons slot-name position)))))
553 (mapcar #'(lambda (slotd)
554 (list (slot-definition-initargs slotd)
555 (or (cdr (assq (slot-definition-name slotd)
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)))))))
575 (gather1 (cons initarg positions))))))))
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
580 (define-constructor-code-type fallback
581 (class name arglist supplied-initarg-names supplied-initargs)
582 (declare (ignore name supplied-initarg-names))
584 (lambda (&rest ignore)
585 (declare (ignore ignore))
587 (sb-kernel:instance-lambda ,arglist
590 ,@(gathering1 (collecting)
591 (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
592 (gather1 `',(car tail))
593 (gather1 (cadr tail))))))))))
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)))
607 (lambda (class .wrapper. defaults init shared)
608 (multiple-value-bind (.constants.
610 .initfns-initargs-and-positions.
611 .supplied-initarg-positions.
614 (general-generator-internal class
618 ',supplied-initarg-names
620 .supplied-initarg-positions.
621 (when (and .constants.
622 (null (non-pcl-or-after-initialize-instance-methods-p
624 (null (non-pcl-or-after-shared-initialize-methods-p
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.))
635 (dolist (entry .initfns-initargs-and-positions.)
636 (let ((val (funcall (car entry)))
637 (initarg (cadr entry)))
639 (push val .initargs.)
640 (push initarg .initargs.))
641 (dolist (pos (cddr entry))
642 (setf (%instance-ref .slots. pos) val))))
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.)
654 (dolist (fn .shared-initfns.)
655 (apply fn .instance. t .initargs.))
656 (dolist (fn .initfns.)
657 (apply fn .instance. .initargs.))
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)))
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 ())
675 ;; Go through each of the supplied initargs for three reasons.
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
684 (doplist (initarg val) supplied-initargs
685 (let ((positions (cdr (assq initarg initarg-positions))))
686 (cond ((memq :class positions) (bail-out))
688 (setq val (eval val))
689 (push val constant-initargs)
690 (push initarg constant-initargs)
691 (dolist (pos positions) (setf (svref constants pos) val)))
693 (push positions supplied-initarg-positions)))
694 (setq used-positions (append positions used-positions))))
696 ;; Go through each of the default initargs, for three reasons.
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))
707 (positions (cdr (assq name initarg-positions))))
708 (unless (memq name supplied-initarg-names)
709 (cond ((memq :class positions) (bail-out))
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)))
717 (push (list* initfn name positions)
718 initfns-initargs-and-positions)))
719 (setq used-positions (append positions used-positions)))))
721 ;; Go through each of the slot initforms:
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)
739 ((member position used-positions))
740 ((or (constantp form)
743 (push (list initfn nil position)
744 initfns-initargs-and-positions)))))
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))))))
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)))
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
772 ',supplied-initarg-names
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.))
786 (dolist (entry .initfns-and-positions.)
787 (let ((val (funcall (car entry))))
788 (dolist (pos (cdr entry))
789 (setf (%instance-ref .slots. pos) val))))
791 ,@(gathering1 (collecting)
792 (doplist (initarg value) supplied-initargs
793 (unless (constantp value)
795 `(let ((.value. ,value))
796 (dolist (.p. (pop .positions.))
797 (setf (%instance-ref .slots. .p.) .value.)))))))
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)))
807 (compute-initarg-positions class
808 (append supplied-initarg-names
809 (mapcar #'car defaults))))
810 (initfns-and-positions ())
811 (supplied-initarg-positions ())
814 ;; Go through each of the supplied initargs for three reasons.
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
823 (doplist (initarg val) supplied-initargs
824 (let ((positions (cdr (assq initarg initarg-positions))))
825 (cond ((memq :class positions) (bail-out))
827 (setq val (eval val))
828 (dolist (pos positions)
829 (setf (svref constants pos) val)))
831 (push positions supplied-initarg-positions)))
832 (setq used-positions (append positions used-positions))))
834 ;; Go through each of the default initargs, for three reasons.
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))
845 (positions (cdr (assq name initarg-positions))))
846 (unless (memq name supplied-initarg-names)
847 (cond ((memq :class positions) (bail-out))
849 (setq value (eval form))
850 (dolist (pos positions)
851 (setf (svref constants pos) value)))
853 (push (cons initfn positions)
854 initfns-and-positions)))
855 (setq used-positions (append positions used-positions)))))
857 ;; Go through each of the slot initforms:
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)
875 ((member position used-positions))
876 ((or (constantp form)
879 (push (list initfn position) initfns-and-positions)))))
882 (nreverse initfns-and-positions)
883 (nreverse supplied-initarg-positions)))))
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)))
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
902 ',supplied-initarg-names
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.))
913 ,@(gathering1 (collecting)
914 (doplist (initarg value) supplied-initargs
915 (unless (constantp value)
917 `(let ((.value. ,value))
918 (dolist (.p. (pop .positions.))
919 (setf (%instance-ref .slots. .p.)
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)))
930 (compute-initarg-positions class
931 (append supplied-initarg-names
932 (mapcar #'car defaults))))
933 (supplied-initarg-positions ())
936 ;; Go through each of the supplied initargs for three reasons.
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
945 (doplist (initarg val) supplied-initargs
946 (let ((positions (cdr (assq initarg initarg-positions))))
947 (cond ((memq :class positions) (bail-out))
949 (setq val (eval val))
950 (dolist (pos positions)
951 (setf (svref constants pos) val)))
953 (push positions supplied-initarg-positions)))
954 (setq used-positions (append used-positions positions))))
956 ;; Go through each of the default initargs for three reasons.
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))
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))
972 (setq value (eval form))
973 (dolist (pos positions)
974 (setf (svref constants pos) value)))))))
976 ;; Go through each of the slot initforms:
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
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)
995 ((member position used-positions))
996 ((or (constantp form)
1001 (values constants (nreverse supplied-initarg-positions)))))