1 ;;;; This file contains the optimization machinery for make-instance.
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from software originally released by
7 ;;;; Gerd Moellmann. Copyright and release statements follow. Later
8 ;;;; modifications to the software are in the public domain and are
9 ;;;; provided with absolutely no warranty. See the COPYING and
10 ;;;; CREDITS files for more information.
12 ;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de>
13 ;;; All rights reserved.
15 ;;; Redistribution and use in source and binary forms, with or without
16 ;;; modification, are permitted provided that the following conditions
19 ;;; 1. Redistributions of source code must retain the above copyright
20 ;;; notice, this list of conditions and the following disclaimer.
21 ;;; 2. Redistributions in binary form must reproduce the above copyright
22 ;;; notice, this list of conditions and the following disclaimer in the
23 ;;; documentation and/or other materials provided with the distribution.
24 ;;; 3. The name of the author may not be used to endorse or promote
25 ;;; products derived from this software without specific prior written
28 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
29 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
30 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
31 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
32 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
33 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
34 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
35 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
36 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
37 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
38 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
45 ;;; Compiler macro for MAKE-INSTANCE, and load-time generation of
46 ;;; optimized instance constructor functions.
48 ;;; ********************
49 ;;; Entry Points ******
50 ;;; ********************
52 ;;; UPDATE-CTORS must be called when methods are added/removed,
53 ;;; classes are changed, etc., which affect instance creation.
55 ;;; PRECOMPILE-CTORS can be called to precompile constructor functions
56 ;;; for classes whose definitions are known at the time the function
61 ;;; ******************
63 ;;; ******************
65 (defun quote-plist-keys (plist)
66 (loop for
(key . more
) on plist by
#'cddr
68 (error "Not a property list: ~S" plist
)
71 and collect
(car more
)))
73 (defun plist-keys (plist &key test
)
74 (loop for
(key . more
) on plist by
#'cddr
76 (error "Not a property list: ~S" plist
)
77 else if
(or (null test
) (funcall test key
))
80 (defun plist-values (plist &key test
)
81 (loop for
(key . more
) on plist by
#'cddr
83 (error "Not a property list: ~S" plist
)
84 else if
(or (null test
) (funcall test
(car more
)))
87 (defun constant-class-arg-p (form)
89 (let ((constant (constant-form-value form
)))
90 (or (and (symbolp constant
)
91 (not (null (symbol-package constant
))))
94 (defun constant-symbol-p (form)
96 (let ((constant (constant-form-value form
)))
97 (and (symbolp constant
)
98 (not (null (symbol-package constant
)))))))
100 ;;; Somewhat akin to DEFAULT-INITARGS, but just collecting the defaulted
101 ;;; initargs for the call.
102 (defun ctor-default-initkeys (supplied-initargs class-default-initargs
)
103 (loop for
(key) in class-default-initargs
104 when
(eq (getf supplied-initargs key
'.not-there.
) '.not-there.
)
107 ;;; Like DEFAULT-INITARGS, but return a list that can be spliced into source,
108 ;;; instead of a list with values already evaluated.
109 (defun ctor-default-initargs (supplied-initargs class-default-initargs
)
110 (loop for
(key form fun
) in class-default-initargs
111 when
(eq (getf supplied-initargs key
'.not-there.
) '.not-there.
)
112 append
(list key
(if (constantp form
) form
`(funcall ,fun
)))
113 into default-initargs
115 (return (append supplied-initargs default-initargs
))))
117 ;;; *****************
119 ;;; *****************
121 ;;; Ctors are funcallable instances whose initial function is a
122 ;;; function computing an optimized constructor function when called.
123 ;;; When the optimized function is computed, the function of the
124 ;;; funcallable instance is set to it.
126 (!defstruct-with-alternate-metaclass ctor
127 :slot-names
(function-name class-or-name class initargs state safe-p
)
128 :boa-constructor %make-ctor
129 :superclass-name function
130 :metaclass-name static-classoid
131 :metaclass-constructor make-static-classoid
132 :dd-type funcallable-structure
133 :runtime-type-checks-p nil
)
135 ;;; List of all defined ctors.
136 (defvar *all-ctors
* ())
138 (defun make-ctor-parameter-list (ctor)
139 (plist-values (ctor-initargs ctor
) :test
(complement #'constantp
)))
141 ;;; Reset CTOR to use a default function that will compute an
142 ;;; optimized constructor function when called.
143 (defun install-initial-constructor (ctor &key force-p
)
144 (when (or force-p
(ctor-class ctor
))
145 (setf (ctor-class ctor
) nil
146 (ctor-state ctor
) 'initial
)
147 (setf (funcallable-instance-fun ctor
)
148 #'(lambda (&rest args
)
149 (install-optimized-constructor ctor
)
151 (setf (%funcallable-instance-info ctor
1)
152 (ctor-function-name ctor
))))
154 (defun make-ctor-function-name (class-name initargs safe-code-p
)
155 (labels ((arg-name (x)
157 ;; this list of types might look arbitrary but it is
158 ;; exactly the set of types descended into by EQUAL,
159 ;; which is the predicate used by globaldb to test for
161 (list (gensym "LIST-INITARG-"))
162 (string (gensym "STRING-INITARG-"))
163 (bit-vector (gensym "BIT-VECTOR-INITARG-"))
164 (pathname (gensym "PATHNAME-INITARG-"))
167 (let ((*gensym-counter
* 0))
168 (mapcar #'arg-name list
))))
169 (list* 'ctor class-name safe-code-p
(munge initargs
))))
171 ;;; Keep this a separate function for testing.
172 (defun ensure-ctor (function-name class-name initargs safe-code-p
)
174 (if (fboundp function-name
)
175 (the ctor
(fdefinition function-name
))
176 (make-ctor function-name class-name initargs safe-code-p
))))
178 ;;; Keep this a separate function for testing.
179 (defun make-ctor (function-name class-name initargs safe-p
)
180 (without-package-locks ; for (setf symbol-function)
181 (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p
)))
182 (install-initial-constructor ctor
:force-p t
)
183 (push ctor
*all-ctors
*)
184 (setf (fdefinition function-name
) ctor
)
187 ;;; *****************
188 ;;; Inline CTOR cache
189 ;;; *****************
191 ;;; The cache starts out as a list of CTORs, sorted with the most recently
192 ;;; used CTORs near the head. If it expands too much, we switch to a vector
193 ;;; with a simple hashing scheme.
195 ;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
196 ;;; is in the list but not one of the 4 first ones, return a new list with the
197 ;;; found CTOR at the head. Thread-safe: the new list shares structure with
198 ;;; the old, but is not desctructively modified. Returning the old list for
199 ;;; hits close to the head reduces ping-ponging with multiple threads seeking
201 (defun find-ctor (key list
)
202 (labels ((walk (tail from-head depth
)
203 (declare (fixnum depth
))
205 (let ((ctor (car tail
)))
206 (if (eq (ctor-class-or-name ctor
) key
)
209 (nconc (list ctor
) (nreverse from-head
) (cdr tail
)))
213 (cons ctor from-head
)
214 (logand #xf
(1+ depth
)))))
218 (declaim (inline sxhash-symbol-or-class
))
219 (defun sxhash-symbol-or-class (x)
220 (cond ((symbolp x
) (sxhash x
))
221 ((std-instance-p x
) (std-instance-hash x
))
222 ((fsc-instance-p x
) (fsc-instance-hash x
))
224 (bug "Something strange where symbol or class expected."))))
226 ;;; Max number of CTORs kept in an inline list cache. Once this is
227 ;;; exceeded we switch to a table.
228 (defconstant +ctor-list-max-size
+ 12)
229 ;;; Max table size for CTOR cache. If the table fills up at this size
230 ;;; we keep the same size and drop 50% of the old entries.
231 (defconstant +ctor-table-max-size
+ (expt 2 8))
232 ;;; Even if there is space in the cache, if we cannot fit a new entry
233 ;;; with max this number of collisions we expand the table (if possible)
235 (defconstant +ctor-table-max-probe-depth
+ 5)
237 (defun make-ctor-table (size)
238 (declare (index size
))
239 (let ((real-size (power-of-two-ceiling size
)))
240 (if (< real-size
+ctor-table-max-size
+)
241 (values (make-array real-size
:initial-element nil
) nil
)
242 (values (make-array +ctor-table-max-size
+ :initial-element nil
) t
))))
244 (declaim (inline mix-ctor-hash
))
245 (defun mix-ctor-hash (hash base
)
246 (logand most-positive-fixnum
(+ hash base
1)))
248 (defun put-ctor (ctor table
)
249 (cond ((try-put-ctor ctor table
)
252 (expand-ctor-table ctor table
))))
254 ;;; Thread-safe: if two threads write to the same index in parallel, the other
255 ;;; result is just lost. This is not an issue as the CTORs are used as their
256 ;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
257 ;;; one is needed we just cache it again -- hopefully not getting stomped on
259 (defun try-put-ctor (ctor table
)
260 (declare (simple-vector table
) (optimize speed
))
261 (let* ((class (ctor-class-or-name ctor
))
262 (base (sxhash-symbol-or-class class
))
264 (mask (1- (length table
))))
265 (declare (fixnum base hash mask
))
266 (loop repeat
+ctor-table-max-probe-depth
+
267 do
(let* ((index (logand mask hash
))
268 (old (aref table index
)))
269 (cond ((and old
(neq class
(ctor-class-or-name old
)))
270 (setf hash
(mix-ctor-hash hash base
)))
272 (setf (aref table index
) ctor
)
273 (return-from try-put-ctor t
)))))
274 ;; Didn't fit, must expand
277 (defun get-ctor (class table
)
278 (declare (simple-vector table
) (optimize speed
))
279 (let* ((base (sxhash-symbol-or-class class
))
281 (mask (1- (length table
))))
282 (declare (fixnum base hash mask
))
283 (loop repeat
+ctor-table-max-probe-depth
+
284 do
(let* ((index (logand mask hash
))
285 (old (aref table index
)))
286 (if (and old
(eq class
(ctor-class-or-name old
)))
287 (return-from get-ctor old
)
288 (setf hash
(mix-ctor-hash hash base
)))))
292 ;;; Thread safe: the old table is read, but if another thread mutates
293 ;;; it while we're reading we still get a sane result -- either the old
294 ;;; or the new entry. The new table is locally allocated, so that's ok
296 (defun expand-ctor-table (ctor old
)
297 (declare (simple-vector old
))
298 (let* ((old-size (length old
))
299 (new-size (* 2 old-size
))
300 (drop-random-entries nil
))
303 (multiple-value-bind (new max-size-p
) (make-ctor-table new-size
)
304 (let ((action (if drop-random-entries
305 ;; Same logic as in method caches -- see comment
307 (randomly-punting-lambda (old-ctor)
308 (try-put-ctor old-ctor new
))
310 (unless (try-put-ctor old-ctor new
)
312 (setf drop-random-entries t
)
313 (setf new-size
(* 2 new-size
)))
315 (aver (try-put-ctor ctor new
))
316 (dotimes (i old-size
)
317 (let ((old-ctor (aref old i
)))
319 (funcall action old-ctor
))))
320 (return-from expand-ctor-table
(values ctor new
)))))))
322 (defun ctor-list-to-table (list)
323 (let ((table (make-ctor-table (length list
))))
325 (setf table
(nth-value 1 (put-ctor ctor table
))))
328 (defun ensure-cached-ctor (class-name store initargs safe-code-p
)
329 (flet ((maybe-ctor-for-caching ()
330 (if (typep class-name
'(or symbol class
))
331 (let ((name (make-ctor-function-name class-name initargs safe-code-p
)))
332 (ensure-ctor name class-name initargs safe-code-p
))
333 ;; Invalid first argument: let MAKE-INSTANCE worry about it.
334 (return-from ensure-cached-ctor
335 (values (lambda (&rest ctor-parameters
)
337 (doplist (key value
) initargs
338 (push key mi-initargs
)
339 (push (if (constantp value
)
341 (pop ctor-parameters
))
343 (apply #'make-instance class-name
(nreverse mi-initargs
))))
346 (multiple-value-bind (ctor list
) (find-ctor class-name store
)
349 (let ((ctor (maybe-ctor-for-caching)))
350 (if (< (length list
) +ctor-list-max-size
+)
351 (values ctor
(cons ctor list
))
352 (values ctor
(ctor-list-to-table list
))))))
353 (let ((ctor (get-ctor class-name store
)))
356 (put-ctor (maybe-ctor-for-caching) store
))))))
358 ;;; ***********************************************
359 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
360 ;;; ***********************************************
362 (defvar *compiling-optimized-constructor
* nil
)
364 (define-compiler-macro make-instance
(&whole form
&rest args
&environment env
)
365 (declare (ignore args
))
366 ;; Compiling an optimized constructor for a non-standard class means
367 ;; compiling a lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it
368 ;; -- need to make sure we don't recurse there.
369 (or (unless *compiling-optimized-constructor
*
370 (make-instance->constructor-call form
(safe-code-p env
)))
373 (defun make-instance->constructor-call
(form safe-code-p
)
374 (destructuring-bind (class-arg &rest args
) (cdr form
)
376 ;; Return the name of parameter number I of a constructor
379 (format-symbol *pcl-package
* ".P~D." i
))
380 ;; Check if CLASS-ARG is a constant symbol. Give up if
383 (and class-arg
(constant-class-arg-p class-arg
)))
384 ;; Check if ARGS are suitable for an optimized constructor.
385 ;; Return NIL from the outer function if not.
387 (loop for
(key . more
) on args by
#'cddr do
388 (when (or (null more
)
389 (not (constant-symbol-p key
))
390 (eq :allow-other-keys
(constant-form-value key
)))
391 (return-from make-instance-
>constructor-call nil
)))))
393 ;; Collect a plist of initargs and constant values/parameter names
394 ;; in INITARGS. Collect non-constant initialization forms in
396 (multiple-value-bind (initargs value-forms
)
397 (loop for
(key value
) on args by
#'cddr and i from
0
398 collect
(constant-form-value key
) into initargs
400 collect value into initargs
402 collect
(parameter-name i
) into initargs
403 and collect value into value-forms
405 (return (values initargs value-forms
)))
406 (if (constant-class-p)
407 (let* ((class-or-name (constant-form-value class-arg
))
408 (function-name (make-ctor-function-name class-or-name initargs
410 (sb-int:check-deprecated-type
(if (classp class-or-name
)
411 (class-name class-or-name
)
413 ;; Prevent compiler warnings for calling the ctor.
414 (proclaim-as-fun-name function-name
)
415 (note-name-defined function-name
:function
)
416 (when (eq (info :function
:where-from function-name
) :assumed
)
417 (setf (info :function
:where-from function-name
) :defined
)
418 (when (info :function
:assumed-type function-name
)
419 (setf (info :function
:assumed-type function-name
) nil
)))
420 ;; Return code constructing a ctor at load time, which,
421 ;; when called, will set its funcallable instance
422 ;; function to an optimized constructor function.
424 (declare (disable-package-locks ,function-name
))
425 (let ((.x.
(load-time-value
426 (ensure-ctor ',function-name
',class-or-name
',initargs
428 (declare (ignore .x.
))
429 ;; ??? check if this is worth it.
431 (ftype (or (function ,(make-list (length value-forms
)
434 (function (&rest t
) t
))
436 (funcall (function ,function-name
) ,@value-forms
))))
437 (when (and class-arg
(not (constantp class-arg
)))
438 ;; Build an inline cache: a CONS, with the actual cache
440 `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
442 (let* ((.cache.
(load-time-value (cons 'ctor-cache nil
)))
443 (.store.
(cdr .cache.
))
444 (.class-arg.
,class-arg
))
445 (multiple-value-bind (.fun. .new-store.
)
446 (ensure-cached-ctor .class-arg. .store.
',initargs
',safe-code-p
)
447 ;; Thread safe: if multiple threads hit this in
448 ;; parallel, the update from the other one is
449 ;; just lost -- no harm done, except for the need
450 ;; to redo the work next time.
451 (unless (eq .store. .new-store.
)
452 (setf (cdr .cache.
) .new-store.
))
453 (funcall (truly-the function .fun.
) ,@value-forms
))))))))))
455 ;;; **************************************************
456 ;;; Load-Time Constructor Function Generation *******
457 ;;; **************************************************
459 ;;; The system-supplied primary INITIALIZE-INSTANCE and
460 ;;; SHARED-INITIALIZE methods. One cannot initialize these variables
461 ;;; to the right values here because said functions don't exist yet
462 ;;; when this file is first loaded.
463 (defvar *the-system-ii-method
* nil
)
464 (defvar *the-system-si-method
* nil
)
466 (defun install-optimized-constructor (ctor)
468 (let* ((class-or-name (ctor-class-or-name ctor
))
469 (class (ensure-class-finalized
470 (if (symbolp class-or-name
)
471 (find-class class-or-name
)
473 ;; We can have a class with an invalid layout here. Such a class
474 ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
475 ;; ...), because part of the deal is that those only happen from
476 ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
477 ;; class. An invalid layout of T needs to be flushed, however.
478 (when (eq (layout-invalid (class-wrapper class
)) t
)
479 (%force-cache-flushes class
))
480 (setf (ctor-class ctor
) class
)
481 (pushnew ctor
(plist-value class
'ctors
) :test
#'eq
)
482 (multiple-value-bind (form locations names optimizedp
)
483 (constructor-function-form ctor
)
484 (setf (funcallable-instance-fun ctor
)
486 (let ((*compiling-optimized-constructor
* t
))
487 (handler-bind ((compiler-note #'muffle-warning
))
488 (compile nil
`(lambda ,names
,form
))))
490 (ctor-state ctor
) (if optimizedp
'optimized
'fallback
))))))
492 (defun constructor-function-form (ctor)
493 (let* ((class (ctor-class ctor
))
494 (proto (class-prototype class
))
495 (make-instance-methods
496 (compute-applicable-methods #'make-instance
(list class
)))
497 (allocate-instance-methods
498 (compute-applicable-methods #'allocate-instance
(list class
)))
499 ;; I stared at this in confusion for a while, thinking
500 ;; carefully about the possibility of the class prototype not
501 ;; being of sufficient discrimiating power, given the
502 ;; possibility of EQL-specialized methods on
503 ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given
504 ;; that this is a constructor optimization, the user doesn't
505 ;; yet have the instance to create a method with such an EQL
508 ;; There remains the (theoretical) possibility of someone
509 ;; coming along with code of the form
511 ;; (defmethod initialize-instance :before ((o foo) ...)
512 ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
514 ;; but probably we can afford not to worry about this too
515 ;; much for now. -- CSR, 2004-07-12
517 (compute-applicable-methods #'initialize-instance
(list proto
)))
519 (compute-applicable-methods #'shared-initialize
(list proto t
)))
521 (loop for slot in
(class-slots class
)
522 when
(cdr (compute-applicable-methods
523 #'(setf slot-value-using-class
)
524 (list nil class proto slot
)))
527 (loop for slot in
(class-slots class
)
528 when
(cdr (compute-applicable-methods
529 #'slot-boundp-using-class
530 (list class proto slot
)))
532 ;; Cannot initialize these variables earlier because the generic
533 ;; functions don't exist when PCL is built.
534 (when (null *the-system-si-method
*)
535 (setq *the-system-si-method
*
536 (find-method #'shared-initialize
537 () (list *the-class-slot-object
* *the-class-t
*)))
538 (setq *the-system-ii-method
*
539 (find-method #'initialize-instance
540 () (list *the-class-slot-object
*))))
541 ;; Note that when there are user-defined applicable methods on
542 ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
543 ;; together with the system-defined ones in what
544 ;; COMPUTE-APPLICABLE-METHODS returns.
545 (let ((maybe-invalid-initargs
549 (ctor-default-initkeys
550 (ctor-initargs ctor
) (class-default-initargs class
))
551 (plist-keys (ctor-initargs ctor
)))
552 (append ii-methods si-methods
) nil nil
))
553 (custom-make-instance
554 (not (null (cdr make-instance-methods
)))))
555 (if (and (not (structure-class-p class
))
556 (not (condition-class-p class
))
557 (not custom-make-instance
)
558 (null (cdr allocate-instance-methods
))
560 (member (slot-definition-allocation x
)
561 '(:instance
:class
)))
563 (not maybe-invalid-initargs
)
564 (not (hairy-around-or-nonstandard-primary-method-p
565 ii-methods
*the-system-ii-method
*))
566 (not (around-or-nonstandard-primary-method-p
567 si-methods
*the-system-si-method
*)))
568 (optimizing-generator ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
569 (fallback-generator ctor ii-methods si-methods
570 (or maybe-invalid-initargs custom-make-instance
))))))
572 (defun around-or-nonstandard-primary-method-p
573 (methods &optional standard-method
)
574 (loop with primary-checked-p
= nil
575 for method in methods
576 as qualifiers
= (if (consp method
)
577 (early-method-qualifiers method
)
578 (safe-method-qualifiers method
))
579 when
(or (eq :around
(car qualifiers
))
580 (and (null qualifiers
)
581 (not primary-checked-p
)
582 (not (null standard-method
))
583 (not (eq standard-method method
))))
585 when
(null qualifiers
) do
586 (setq primary-checked-p t
)))
588 (defun hairy-around-or-nonstandard-primary-method-p
589 (methods &optional standard-method
)
590 (loop with primary-checked-p
= nil
591 for method in methods
592 as qualifiers
= (if (consp method
)
593 (early-method-qualifiers method
)
594 (safe-method-qualifiers method
))
595 when
(or (and (eq :around
(car qualifiers
))
596 (not (simple-next-method-call-p method
)))
597 (and (null qualifiers
)
598 (not primary-checked-p
)
599 (not (null standard-method
))
600 (not (eq standard-method method
))))
602 when
(null qualifiers
) do
603 (setq primary-checked-p t
)))
605 (defun fallback-generator (ctor ii-methods si-methods use-make-instance
)
606 (declare (ignore ii-methods si-methods
))
607 (let ((class (ctor-class ctor
))
608 (lambda-list (make-ctor-parameter-list ctor
))
609 (initargs (ctor-initargs ctor
)))
610 (if use-make-instance
611 `(lambda ,lambda-list
612 (declare #.
*optimize-speed
*)
613 ;; The CTOR MAKE-INSTANCE optimization checks for
614 ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
615 ;; compilation of the constructor, hence avoiding the
616 ;; possibility of endless recursion.
617 (make-instance ,class
,@(quote-plist-keys initargs
)))
618 (let ((defaults (class-default-initargs class
)))
620 (setf initargs
(ctor-default-initargs initargs defaults
)))
621 `(lambda ,lambda-list
622 (declare #.
*optimize-speed
*)
623 (fast-make-instance ,class
,@(quote-plist-keys initargs
)))))))
625 ;;; Not as good as the real optimizing generator, but faster than going
626 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
627 (defun fast-make-instance (class &rest initargs
)
628 (declare #.
*optimize-speed
*)
629 (declare (dynamic-extent initargs
))
630 (let ((.instance.
(apply #'allocate-instance class initargs
)))
631 (apply #'initialize-instance .instance. initargs
)
634 (defun optimizing-generator
635 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
636 (multiple-value-bind (locations names body early-unbound-markers-p
)
637 (fake-initialization-emf ctor ii-methods si-methods
638 setf-svuc-slots sbuc-slots
)
639 (let ((wrapper (class-wrapper (ctor-class ctor
))))
641 `(lambda ,(make-ctor-parameter-list ctor
)
642 (declare #.
*optimize-speed
*)
644 (when (layout-invalid ,wrapper
)
645 (install-initial-constructor ,ctor
)
646 (return (funcall ,ctor
,@(make-ctor-parameter-list ctor
))))
647 ,(wrap-in-allocate-forms ctor body early-unbound-markers-p
)))
652 ;;; Return a form wrapped around BODY that allocates an instance constructed
653 ;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we
654 ;;; have explicitly initialized them, requiring all slots to start as
655 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables .INSTANCE. to
656 ;;; the instance, and .SLOTS. to the instance's slot vector around BODY.
657 (defun wrap-in-allocate-forms (ctor body early-unbound-markers-p
)
658 (let* ((class (ctor-class ctor
))
659 (wrapper (class-wrapper class
))
660 (allocation-function (raw-instance-allocator class
))
661 (slots-fetcher (slots-fetcher class
)))
662 (if (eq allocation-function
'allocate-standard-instance
)
663 `(let ((.instance.
(%make-standard-instance nil
664 (get-instance-hash-code)))
666 ,(layout-length wrapper
)
667 ,@(when early-unbound-markers-p
668 '(:initial-element
+slot-unbound
+)))))
669 (setf (std-instance-wrapper .instance.
) ,wrapper
)
670 (setf (std-instance-slots .instance.
) .slots.
)
673 `(let* ((.instance.
(,allocation-function
,wrapper
))
674 (.slots.
(,slots-fetcher .instance.
)))
675 (declare (ignorable .slots.
))
679 ;;; Return a form for invoking METHOD with arguments from ARGS. As
680 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
681 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could
682 ;;; call fast method functions directly here, but benchmarks show that
683 ;;; there's no speed to gain, so lets avoid the hair here.
684 (defmacro invoke-method
(method args
&optional next-methods
)
685 `(funcall ,(the function
(method-function method
)) ,args
,next-methods
))
687 ;;; Return a form that is sort of an effective method comprising all
688 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
689 ;;; normally have taken place when calling MAKE-INSTANCE.
690 (defun fake-initialization-emf
691 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
692 (multiple-value-bind (ii-around ii-before ii-primary ii-after
)
693 (standard-sort-methods ii-methods
)
694 (declare (ignore ii-primary
))
695 (multiple-value-bind (si-around si-before si-primary si-after
)
696 (standard-sort-methods si-methods
)
697 (declare (ignore si-primary
))
698 (aver (null si-around
))
699 (let ((initargs (ctor-initargs ctor
))
700 ;; :BEFORE and :AROUND initialization methods, and SETF SVUC and
701 ;; SBUC methods can cause slots to be accessed before the we have
702 ;; touched them here, which requires the instance-vector to be
703 ;; initialized with +SLOT-UNBOUND+ to start with.
704 (early-unbound-markers-p (or ii-before si-before ii-around
705 setf-svuc-slots sbuc-slots
)))
707 (locations names bindings vars defaulting-initargs body
)
708 (slot-init-forms ctor
709 early-unbound-markers-p
710 setf-svuc-slots sbuc-slots
)
715 (declare (ignorable ,@vars
))
716 (flet ((initialize-it (.ii-args. .next-methods.
)
717 ;; This has all the :BEFORE and :AFTER methods,
718 ;; and BODY does what primary SI method would do.
719 (declare (ignore .next-methods.
))
720 (let* ((.instance.
(car .ii-args.
))
721 ,@(when (or si-before si-after
)
723 (list* .instance. t
(cdr .ii-args.
))))))
724 ,@(loop for method in ii-before
725 collect
`(invoke-method ,method .ii-args.
))
726 ,@(loop for method in si-before
727 collect
`(invoke-method ,method .si-args.
))
729 ,@(loop for method in si-after
730 collect
`(invoke-method ,method .si-args.
))
731 ,@(loop for method in ii-after
732 collect
`(invoke-method ,method .ii-args.
))
734 (declare (dynamic-extent #'initialize-it
))
736 ,@(if (or ii-before ii-after ii-around si-before si-after
)
737 `((list .instance.
,@(quote-plist-keys initargs
)
738 ,@defaulting-initargs
))
739 `((list .instance.
)))))
741 ;; If there are :AROUND methods, call them first -- they get
742 ;; the normal chaining, with #'INITIALIZE-IT standing in for
744 `(let ((.next-methods.
745 (list ,@(cdr ii-around
) #'initialize-it
)))
746 (declare (dynamic-extent .next-methods.
))
747 (invoke-method ,(car ii-around
) .ii-args. .next-methods.
))
749 `(initialize-it .ii-args. nil
)))))
750 early-unbound-markers-p
))))))
752 ;;; Return four values from APPLICABLE-METHODS: around methods, before
753 ;;; methods, the applicable primary method, and applicable after
754 ;;; methods. Before and after methods are sorted in the order they
756 (defun standard-sort-methods (applicable-methods)
757 (loop for method in applicable-methods
758 as qualifiers
= (if (consp method
)
759 (early-method-qualifiers method
)
760 (safe-method-qualifiers method
))
762 collect method into primary
763 else if
(eq :around
(car qualifiers
))
764 collect method into around
765 else if
(eq :after
(car qualifiers
))
766 collect method into after
767 else if
(eq :before
(car qualifiers
))
768 collect method into before
770 (return (values around before
(first primary
) (reverse after
)))))
772 (defmacro with-type-checked
((type safe-p
) &body body
)
774 ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
775 ;; THE instead of e.g. CHECK-TYPE.
777 (declare (optimize (safety 3)))
778 (the ,type
(progn ,@body
)))
781 ;;; Return as multiple values bindings for default initialization arguments,
782 ;;; variable names, defaulting initargs and a body for initializing instance
783 ;;; and class slots of an object costructed by CTOR. The variable .SLOTS. is
784 ;;; assumed to bound to the instance's slot vector. EARLY-UNBOUND-MARKERS-P
785 ;;; means other code will initialize instance slots to +SLOT-UNBOUND+, and we
786 ;;; have to check if something has already set slots before we initialize
788 (defun slot-init-forms (ctor early-unbound-markers-p setf-svuc-slots sbuc-slots
)
789 (let* ((class (ctor-class ctor
))
790 (initargs (ctor-initargs ctor
))
791 (initkeys (plist-keys initargs
))
792 (safe-p (ctor-safe-p ctor
))
793 (wrapper (class-wrapper class
))
795 (make-array (layout-length wrapper
) :initial-element nil
))
798 (defaulting-initargs ())
799 (default-initargs (class-default-initargs class
))
801 (compute-initarg-locations
802 class
(append initkeys
(mapcar #'car default-initargs
)))))
803 (labels ((initarg-locations (initarg)
804 (cdr (assoc initarg initarg-locations
:test
#'eq
)))
805 (initializedp (location)
808 (assoc location class-inits
:test
#'eq
))
810 (not (null (aref slot-vector location
))))
811 (t (bug "Weird location in ~S" 'slot-init-forms
))))
812 (class-init (location kind val type slotd
)
813 (aver (consp location
))
814 (unless (initializedp location
)
815 (push (list location kind val type slotd
) class-inits
)))
816 (instance-init (location kind val type slotd
)
817 (aver (integerp location
))
818 (unless (initializedp location
)
819 (setf (aref slot-vector location
)
820 (list kind val type slotd
))))
821 (default-init-var-name (i)
822 (format-symbol *pcl-package
* ".D~D." i
))
823 (location-var-name (i)
824 (format-symbol *pcl-package
* ".L~D." i
)))
825 ;; Loop over supplied initargs and values and record which
826 ;; instance and class slots they initialize.
827 (loop for
(key value
) on initargs by
#'cddr
828 as kind
= (if (constantp value
) 'constant
'param
)
829 as locations
= (initarg-locations key
)
830 do
(loop for
(location type slotd
) in locations
831 do
(if (consp location
)
832 (class-init location kind value type slotd
)
833 (instance-init location kind value type slotd
))))
834 ;; Loop over default initargs of the class, recording
835 ;; initializations of slots that have not been initialized
836 ;; above. Default initargs which are not in the supplied
837 ;; initargs are treated as if they were appended to supplied
838 ;; initargs, that is, their values must be evaluated even
839 ;; if not actually used for initializing a slot.
840 (loop for
(key initform initfn
) in default-initargs and i from
0
841 unless
(member key initkeys
:test
#'eq
)
842 do
(let* ((kind (if (constantp initform
) 'constant
'var
))
843 (init (if (eq kind
'var
) initfn initform
)))
846 (push (list 'quote key
) defaulting-initargs
)
847 (push initform defaulting-initargs
))
849 (push (list 'quote key
) defaulting-initargs
)
850 (push (default-init-var-name i
) defaulting-initargs
)))
852 (let ((init-var (default-init-var-name i
)))
854 (push (cons init-var initfn
) default-inits
)))
855 (loop for
(location type slotd
) in
(initarg-locations key
)
856 do
(if (consp location
)
857 (class-init location kind init type slotd
)
858 (instance-init location kind init type slotd
)))))
859 ;; Loop over all slots of the class, filling in the rest from
861 (loop for slotd in
(class-slots class
)
862 as location
= (slot-definition-location slotd
)
863 as type
= (slot-definition-type slotd
)
864 as allocation
= (slot-definition-allocation slotd
)
865 as initfn
= (slot-definition-initfunction slotd
)
866 as initform
= (slot-definition-initform slotd
) do
867 (unless (or (eq allocation
:class
)
869 (initializedp location
))
870 (if (constantp initform
)
871 (instance-init location
'initform initform type slotd
)
872 (instance-init location
873 'initform
/initfn initfn type slotd
))))
874 ;; Generate the forms for initializing instance and class slots.
875 (let ((instance-init-forms
876 (loop for slot-entry across slot-vector and i from
0
877 as
(kind value type slotd
) = slot-entry
879 (flet ((setf-form (value-form)
880 (if (member slotd setf-svuc-slots
:test
#'eq
)
881 `(setf (slot-value-using-class
882 ,class .instance.
,slotd
)
884 `(setf (clos-slots-ref .slots.
,i
)
885 (with-type-checked (,type
,safe-p
)
888 (if (member slotd sbuc-slots
:test
#'eq
)
889 `(not (slot-boundp-using-class
890 ,class .instance.
,slotd
))
891 `(eq (clos-slots-ref .slots.
,i
)
895 (unless early-unbound-markers-p
896 `(setf (clos-slots-ref .slots.
,i
)
901 (setf-form `(funcall ,value
)))
903 (if early-unbound-markers-p
904 `(when ,(not-boundp-form)
905 ,(setf-form `(funcall ,value
)))
906 (setf-form `(funcall ,value
))))
908 (if early-unbound-markers-p
909 `(when ,(not-boundp-form)
910 ,(setf-form `',(constant-form-value value
)))
911 (setf-form `',(constant-form-value value
))))
913 (setf-form `',(constant-form-value value
))))))))
914 ;; we are not allowed to modify QUOTEd locations, so we can't
915 ;; generate code like (setf (cdr ',location) arg). Instead,
916 ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
917 ;; be bound to the location.
918 (multiple-value-bind (names locations class-init-forms
)
922 for
(location kind value type slotd
) in class-inits
925 (constant `',(constant-form-value value
))
926 ((param var
) `,value
)
927 (initfn `(funcall ,value
)))
928 when
(member slotd setf-svuc-slots
:test
#'eq
)
929 collect
`(setf (slot-value-using-class
930 ,class .instance.
,slotd
)
932 into class-init-forms
934 (let ((name (location-var-name (incf i
))))
936 (push location locations
)
938 (with-type-checked (,type
,safe-p
)
940 into class-init-forms
941 finally
(return (values (nreverse names
)
944 (multiple-value-bind (vars bindings
)
945 (loop for
(var . initfn
) in
(nreverse default-inits
)
946 collect var into vars
947 collect
`(,var
(funcall ,initfn
)) into bindings
948 finally
(return (values vars bindings
)))
949 (values locations names
951 (nreverse defaulting-initargs
)
952 `(,@(delete nil instance-init-forms
)
953 ,@class-init-forms
))))))))
955 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
956 ;;; telling, for each key in INITKEYS, which locations the initarg
957 ;;; initializes and the associated type with the location. CLASS is
958 ;;; the class of the instance being initialized.
959 (defun compute-initarg-locations (class initkeys
)
960 (loop with slots
= (class-slots class
)
961 for key in initkeys collect
962 (loop for slot in slots
963 if
(memq key
(slot-definition-initargs slot
))
964 collect
(list (slot-definition-location slot
)
965 (slot-definition-type slot
)
969 collect slot into remaining-slots
971 (setq slots remaining-slots
)
972 (return (cons key locations
)))))
975 ;;; *******************************
976 ;;; External Entry Points ********
977 ;;; *******************************
979 (defun update-ctors (reason &key class name generic-function method
)
980 (labels ((reset (class &optional initarg-caches-p
(ctorsp t
))
982 (dolist (ctor (plist-value class
'ctors
))
983 (install-initial-constructor ctor
)))
984 (when initarg-caches-p
985 (dolist (cache '(mi-initargs ri-initargs
))
986 (setf (plist-value class cache
) ())))
987 (dolist (subclass (class-direct-subclasses class
))
988 (reset subclass initarg-caches-p ctorsp
))))
990 ;; CLASS must have been specified.
991 (finalize-inheritance
993 ;; NAME must have been specified.
995 (loop for ctor in
*all-ctors
*
996 when
(eq (ctor-class-or-name ctor
) name
) do
997 (when (ctor-class ctor
)
998 (reset (ctor-class ctor
)))
1000 ;; GENERIC-FUNCTION and METHOD must have been specified.
1001 ((add-method remove-method
)
1002 (flet ((class-of-1st-method-param (method)
1003 (type-class (first (method-specializers method
)))))
1004 (case (generic-function-name generic-function
)
1005 ((make-instance allocate-instance
)
1006 ;; FIXME: I can't see a way of working out which classes a
1007 ;; given metaclass specializer are applicable to short of
1008 ;; iterating and testing with class-of. It would be good
1009 ;; to not invalidate caches of system classes at this
1010 ;; point (where it is not legal to define a method
1011 ;; applicable to them on system functions). -- CSR,
1013 (reset (find-class 'standard-object
) t t
))
1014 ((initialize-instance shared-initialize
)
1015 (reset (class-of-1st-method-param method
) t t
))
1016 ((reinitialize-instance)
1017 (reset (class-of-1st-method-param method
) t nil
))
1018 (t (when (or (eq (generic-function-name generic-function
)
1019 'slot-boundp-using-class
)
1020 (equal (generic-function-name generic-function
)
1021 '(setf slot-value-using-class
)))
1022 ;; this looks awfully expensive, but given that one
1023 ;; can specialize on the SLOTD argument, nothing is
1024 ;; safe. -- CSR, 2004-07-12
1025 (reset (find-class 'standard-object
))))))))))
1027 (defun precompile-ctors ()
1028 (dolist (ctor *all-ctors
*)
1029 (when (null (ctor-class ctor
))
1030 (let ((class (find-class (ctor-class-or-name ctor
) nil
)))
1031 (when (and class
(class-finalized-p class
))
1032 (install-optimized-constructor ctor
))))))
1034 (defun maybe-call-ctor (class initargs
)
1035 (flet ((frob-initargs (ctor)
1036 (do ((ctail (ctor-initargs ctor
))
1039 ((or (null ctail
) (null itail
))
1040 (values (nreverse args
) (and (null ctail
) (null itail
))))
1041 (unless (eq (pop ctail
) (pop itail
))
1043 (let ((cval (pop ctail
))
1045 (if (constantp cval
)
1046 (unless (eql cval ival
)
1048 (push ival args
))))))
1049 (dolist (ctor (plist-value class
'ctors
))
1050 (when (eq (ctor-state ctor
) 'optimized
)
1051 (multiple-value-bind (ctor-args matchp
)
1052 (frob-initargs ctor
)
1054 (return (apply ctor ctor-args
))))))))
1056 ;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
1057 (defun check-mi-initargs (class initargs
)
1058 (let* ((class-proto (class-prototype class
))
1059 (keys (plist-keys initargs
))
1060 (cache (plist-value class
'mi-initargs
))
1061 (cached (assoc keys cache
:test
#'equal
))
1068 (list (list* 'allocate-instance class initargs
)
1069 (list* 'initialize-instance class-proto initargs
)
1070 (list* 'shared-initialize class-proto t initargs
))
1072 (setf (plist-value class
'mi-initargs
)
1073 (acons keys invalid cache
))
1076 ;; FIXME: should have an operation here, and maybe a set of
1078 (error 'initarg-error
:class class
:initargs invalid-keys
))))
1080 (defun check-ri-initargs (instance initargs
)
1081 (let* ((class (class-of instance
))
1082 (keys (plist-keys initargs
))
1083 (cache (plist-value class
'ri-initargs
))
1084 (cached (assoc keys cache
:test
#'equal
))
1089 ;; FIXME: give CHECK-INITARGS-1 and friends a
1090 ;; more mnemonic name and (possibly) a nicer,
1091 ;; more orthogonal interface.
1094 (list (list* 'reinitialize-instance instance initargs
)
1095 (list* 'shared-initialize instance nil initargs
))
1097 (setf (plist-value class
'ri-initargs
)
1098 (acons keys invalid cache
))
1101 (error 'initarg-error
:class class
:initargs invalid-keys
))))
1103 ;;; end of ctor.lisp