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.
127 ;;; Type is either CTOR, for MAKE-INSTANCE, or ALLOCATOR, for ALLOCATE-INSTANCE
128 (!defstruct-with-alternate-metaclass ctor
129 :slot-names
(type class-or-name class initargs state safe-p
)
130 :boa-constructor %make-ctor
131 :superclass-name function
132 :metaclass-name static-classoid
133 :metaclass-constructor make-static-classoid
134 :dd-type funcallable-structure
135 :runtime-type-checks-p nil
)
137 ;;; All defined ctors.
138 (defglobal *all-ctors
* (make-hash-table :test
#'equal
140 (declaim (hash-table *all-ctors
*))
142 (defun make-ctor-parameter-list (ctor)
143 (plist-values (ctor-initargs ctor
) :test
(complement #'constantp
)))
145 ;;; Reset CTOR to use a default function that will compute an
146 ;;; optimized constructor function when called.
147 (defun install-initial-constructor (ctor &key force-p
)
148 (when (or force-p
(ctor-class ctor
))
149 (setf (ctor-class ctor
) nil
150 (ctor-state ctor
) 'initial
)
151 (setf (funcallable-instance-fun ctor
)
152 (ecase (ctor-type ctor
)
155 (install-optimized-constructor ctor
)
159 (install-optimized-allocator ctor
)
162 (defun make-ctor-function-name (class-name initargs safe-code-p
)
163 (labels ((arg-name (x)
165 ;; this list of types might look arbitrary but it is
166 ;; exactly the set of types descended into by EQUAL,
167 ;; which is the predicate used by globaldb to test for
170 (list (gensym "LIST-INITARG-"))
171 (string (gensym "STRING-INITARG-"))
172 (bit-vector (gensym "BIT-VECTOR-INITARG-"))
173 (pathname (gensym "PATHNAME-INITARG-"))
176 (let ((*gensym-counter
* 0))
177 (mapcar #'arg-name list
))))
178 (list* 'ctor class-name safe-code-p
(munge initargs
))))
180 ;;; Keep this a separate function for testing.
181 (defun ensure-ctor (function-name class-name initargs safe-code-p
)
183 (or (gethash function-name
*all-ctors
*)
184 (make-ctor function-name class-name initargs safe-code-p
))))
186 ;;; Keep this a separate function for testing.
187 (defun make-ctor (function-name class-name initargs safe-p
)
188 (let ((ctor (%make-ctor
'ctor class-name nil initargs nil safe-p
)))
189 (install-initial-constructor ctor
:force-p t
)
190 (setf (gethash function-name
*all-ctors
*) ctor
)
193 (defun ensure-allocator (function-name class-name
)
195 (or (gethash function-name
*all-ctors
*)
196 (make-allocator function-name class-name
))))
198 (defun make-allocator (function-name class-name
)
199 (let ((ctor (%make-ctor
'allocator class-name nil nil nil nil
)))
200 (install-initial-constructor ctor
:force-p t
)
201 (setf (gethash function-name
*all-ctors
*) ctor
)
204 ;;; *****************
205 ;;; Inline CTOR cache
206 ;;; *****************
208 ;;; The cache starts out as a list of CTORs, sorted with the most recently
209 ;;; used CTORs near the head. If it expands too much, we switch to a vector
210 ;;; with a simple hashing scheme.
212 ;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
213 ;;; is in the list but not one of the 4 first ones, return a new list with the
214 ;;; found CTOR at the head. Thread-safe: the new list shares structure with
215 ;;; the old, but is not desctructively modified. Returning the old list for
216 ;;; hits close to the head reduces ping-ponging with multiple threads seeking
218 (defun find-ctor (key list
)
219 (labels ((walk (tail from-head depth
)
220 (declare (fixnum depth
))
222 (let ((ctor (car tail
)))
223 (if (eq (ctor-class-or-name ctor
) key
)
226 (nconc (list ctor
) (nreverse from-head
) (cdr tail
)))
230 (cons ctor from-head
)
231 (logand #xf
(1+ depth
)))))
235 (declaim (inline sxhash-symbol-or-class
))
236 (defun sxhash-symbol-or-class (x)
237 (cond ((symbolp x
) (sxhash x
))
238 ((std-instance-p x
) (sb-impl::std-instance-hash x
))
239 ((fsc-instance-p x
) (sb-impl::fsc-instance-hash x
))
241 (bug "Something strange where symbol or class expected."))))
243 ;;; Max number of CTORs kept in an inline list cache. Once this is
244 ;;; exceeded we switch to a table.
245 (defconstant +ctor-list-max-size
+ 12)
246 ;;; Max table size for CTOR cache. If the table fills up at this size
247 ;;; we keep the same size and drop 50% of the old entries.
248 (defconstant +ctor-table-max-size
+ (expt 2 8))
249 ;;; Even if there is space in the cache, if we cannot fit a new entry
250 ;;; with max this number of collisions we expand the table (if possible)
252 (defconstant +ctor-table-max-probe-depth
+ 5)
254 (defun make-ctor-table (size)
255 (declare (index size
))
256 (let ((real-size (power-of-two-ceiling size
)))
257 (if (< real-size
+ctor-table-max-size
+)
258 (values (make-array real-size
:initial-element nil
) nil
)
259 (values (make-array +ctor-table-max-size
+ :initial-element nil
) t
))))
261 (declaim (inline mix-ctor-hash
))
262 (defun mix-ctor-hash (hash base
)
263 (logand most-positive-fixnum
(+ hash base
1)))
265 (defun put-ctor (ctor table
)
266 (cond ((try-put-ctor ctor table
)
269 (expand-ctor-table ctor table
))))
271 ;;; Thread-safe: if two threads write to the same index in parallel, the other
272 ;;; result is just lost. This is not an issue as the CTORs are used as their
273 ;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
274 ;;; one is needed we just cache it again -- hopefully not getting stomped on
276 (defun try-put-ctor (ctor table
)
277 (declare (simple-vector table
) (optimize speed
))
278 (let* ((class (ctor-class-or-name ctor
))
279 (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 (cond ((and old
(neq class
(ctor-class-or-name old
)))
287 (setf hash
(mix-ctor-hash hash base
)))
289 (setf (aref table index
) ctor
)
290 (return-from try-put-ctor t
)))))
291 ;; Didn't fit, must expand
294 (defun get-ctor (class table
)
295 (declare (simple-vector table
) (optimize speed
))
296 (let* ((base (sxhash-symbol-or-class class
))
298 (mask (1- (length table
))))
299 (declare (fixnum base hash mask
))
300 (loop repeat
+ctor-table-max-probe-depth
+
301 do
(let* ((index (logand mask hash
))
302 (old (aref table index
)))
303 (if (and old
(eq class
(ctor-class-or-name old
)))
304 (return-from get-ctor old
)
305 (setf hash
(mix-ctor-hash hash base
)))))
309 ;;; Thread safe: the old table is read, but if another thread mutates
310 ;;; it while we're reading we still get a sane result -- either the old
311 ;;; or the new entry. The new table is locally allocated, so that's ok
313 (defun expand-ctor-table (ctor old
)
314 (declare (simple-vector old
))
315 (let* ((old-size (length old
))
316 (new-size (* 2 old-size
))
317 (drop-random-entries nil
))
320 (multiple-value-bind (new max-size-p
) (make-ctor-table new-size
)
321 (let ((action (if drop-random-entries
322 ;; Same logic as in method caches -- see comment
324 (randomly-punting-lambda (old-ctor)
325 (try-put-ctor old-ctor new
))
327 (unless (try-put-ctor old-ctor new
)
329 (setf drop-random-entries t
)
330 (setf new-size
(* 2 new-size
)))
332 (aver (try-put-ctor ctor new
))
333 (dotimes (i old-size
)
334 (let ((old-ctor (aref old i
)))
336 (funcall action old-ctor
))))
337 (return-from expand-ctor-table
(values ctor new
)))))))
339 (defun ctor-list-to-table (list)
340 (let ((table (make-ctor-table (length list
))))
342 (setf table
(nth-value 1 (put-ctor ctor table
))))
345 (defun ensure-cached-ctor (class-name store initargs safe-code-p
)
346 (flet ((maybe-ctor-for-caching ()
347 (if (typep class-name
'(or symbol class
))
348 (let ((name (make-ctor-function-name class-name initargs safe-code-p
)))
349 (ensure-ctor name class-name initargs safe-code-p
))
350 ;; Invalid first argument: let MAKE-INSTANCE worry about it.
351 (return-from ensure-cached-ctor
352 (values (lambda (&rest ctor-parameters
)
354 (doplist (key value
) initargs
355 (push key mi-initargs
)
356 (push (if (constantp value
)
358 (pop ctor-parameters
))
360 (apply #'make-instance class-name
(nreverse mi-initargs
))))
363 (multiple-value-bind (ctor list
) (find-ctor class-name store
)
366 (let ((ctor (maybe-ctor-for-caching)))
367 (if (< (length list
) +ctor-list-max-size
+)
368 (values ctor
(cons ctor list
))
369 (values ctor
(ctor-list-to-table list
))))))
370 (let ((ctor (get-ctor class-name store
)))
373 (put-ctor (maybe-ctor-for-caching) store
))))))
375 (defun ensure-cached-allocator (class store
)
376 (flet ((maybe-ctor-for-caching ()
378 (let ((function-name (list 'ctor
'allocator class
)))
379 (declare (dynamic-extent function-name
))
381 (or (gethash function-name
*all-ctors
*)
382 (make-allocator (copy-list function-name
) class
))))
383 ;; Invalid first argument: let ALLOCATE-INSTANCE worry about it.
384 (return-from ensure-cached-allocator
386 (declare (notinline allocate-instance
))
387 (allocate-instance class
))
390 (multiple-value-bind (ctor list
) (find-ctor class store
)
393 (let ((ctor (maybe-ctor-for-caching)))
394 (if (< (length list
) +ctor-list-max-size
+)
395 (values ctor
(cons ctor list
))
396 (values ctor
(ctor-list-to-table list
))))))
397 (let ((ctor (get-ctor class store
)))
400 (put-ctor (maybe-ctor-for-caching) store
))))))
402 ;;; ***********************************************
403 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
404 ;;; ***********************************************
406 (defvar *compiling-optimized-constructor
* nil
)
408 ;;; There are some MAKE-INSTANCE calls compiled prior to this macro definition.
409 ;;; While it would be trivial to move earlier, I'm not sure that it would
412 ;;; This used to be a compiler macro but compiler macros are invoked
413 ;;; before FOP compilation, while source transforms aren't, there's no
414 ;;; reason to optimize make-instance for top-level forms
415 (sb-c:define-source-transform make-instance
(&whole form
&rest args
&environment env
)
416 ;; Compiling an optimized constructor for a non-standard class means
417 ;; compiling a lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it
418 ;; -- need to make sure we don't recurse there.
419 (or (unless (or *compiling-optimized-constructor
*
421 (make-instance->constructor-call form
(safe-code-p env
)))
424 (sb-c:define-source-transform allocate-instance
(class &rest initargs
)
425 (if (or *compiling-optimized-constructor
*
428 (allocate-instance->constructor-call class
)))
430 (defun allocate-instance->constructor-call
(class-arg)
431 (let ((constant-class (if (classp class-arg
)
433 (and (proper-list-of-length-p class-arg
2)
434 (eq (car class-arg
) 'find-class
)
435 (proper-list-of-length-p (cadr class-arg
) 2)
436 (eq (caadr class-arg
) 'quote
)
437 (symbolp (cadadr class-arg
))
438 (cadadr class-arg
)))))
440 (let* ((class-or-name constant-class
)
441 (function-name (list 'ctor
'allocator class-or-name
)))
442 (sb-int:check-deprecated-type
(if (classp class-or-name
)
443 (class-name class-or-name
)
445 ;; Return code constructing a ctor at load time, which,
446 ;; when called, will set its funcallable instance
447 ;; function to an optimized constructor function.
448 `(funcall (truly-the function
450 (ensure-allocator ',function-name
',class-or-name
) t
))))
451 `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
))
452 (let* ((.cache.
(load-time-value (cons 'ctor-cache nil
)))
453 (.store.
(cdr .cache.
))
454 (.class-arg.
,class-arg
))
455 (multiple-value-bind (.fun. .new-store.
)
456 (ensure-cached-allocator .class-arg. .store.
)
457 ;; Thread safe: if multiple threads hit this in
458 ;; parallel, the update from the other one is
459 ;; just lost -- no harm done, except for the need
460 ;; to redo the work next time.
461 (unless (eq .store. .new-store.
)
462 (setf (cdr .cache.
) .new-store.
))
463 (funcall (truly-the function .fun.
))))))))
465 (defun make-instance->constructor-call
(form safe-code-p
)
466 (destructuring-bind (class-arg &rest args
) (cdr form
)
468 ;; Return the name of parameter number I of a constructor
471 (format-symbol *pcl-package
* ".P~D." i
))
472 ;; Check if CLASS-ARG is a constant symbol. Give up if
475 (and class-arg
(constant-class-arg-p class-arg
)))
476 ;; Check if ARGS are suitable for an optimized constructor.
477 ;; Return NIL from the outer function if not.
479 (loop for
(key . more
) on args by
#'cddr do
480 (when (or (null more
)
481 (not (constant-symbol-p key
))
482 (eq :allow-other-keys
(constant-form-value key
)))
483 (return-from make-instance-
>constructor-call nil
)))))
485 ;; Collect a plist of initargs and constant values/parameter names
486 ;; in INITARGS. Collect non-constant initialization forms in
488 (multiple-value-bind (initargs value-forms
)
489 (loop for
(key value
) on args by
#'cddr and i from
0
490 collect
(constant-form-value key
) into initargs
492 collect value into initargs
494 collect
(parameter-name i
) into initargs
495 and collect value into value-forms
497 (return (values initargs value-forms
)))
498 (if (constant-class-p)
499 (let* ((class-or-name (constant-form-value class-arg
))
500 (function-name (make-ctor-function-name class-or-name initargs
502 (sb-int:check-deprecated-type
(if (classp class-or-name
)
503 (class-name class-or-name
)
505 ;; Return code constructing a ctor at load time, which,
506 ;; when called, will set its funcallable instance
507 ;; function to an optimized constructor function.
508 `(funcall (truly-the function
510 (ensure-ctor ',function-name
',class-or-name
',initargs
514 (when (and class-arg
(not (constantp class-arg
)))
515 ;; Build an inline cache: a CONS, with the actual cache
517 `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
519 (let* ((.cache.
(load-time-value (cons 'ctor-cache nil
)))
520 (.store.
(cdr .cache.
))
521 (.class-arg.
,class-arg
))
522 (multiple-value-bind (.fun. .new-store.
)
523 (ensure-cached-ctor .class-arg. .store.
',initargs
',safe-code-p
)
524 ;; Thread safe: if multiple threads hit this in
525 ;; parallel, the update from the other one is
526 ;; just lost -- no harm done, except for the need
527 ;; to redo the work next time.
528 (unless (eq .store. .new-store.
)
529 (setf (cdr .cache.
) .new-store.
))
530 (funcall (truly-the function .fun.
) ,@value-forms
))))))))))
532 ;;; **************************************************
533 ;;; Load-Time Constructor Function Generation *******
534 ;;; **************************************************
536 ;;; The system-supplied primary INITIALIZE-INSTANCE and
537 ;;; SHARED-INITIALIZE methods. One cannot initialize these variables
538 ;;; to the right values here because said functions don't exist yet
539 ;;; when this file is first loaded.
540 (defvar *the-system-ii-method
* nil
)
541 (defvar *the-system-si-method
* nil
)
543 (defun install-optimized-constructor (ctor)
545 (let* ((class-or-name (ctor-class-or-name ctor
))
546 (class (ensure-class-finalized
547 (if (symbolp class-or-name
)
548 (find-class class-or-name
)
550 ;; We can have a class with an invalid layout here. Such a class
551 ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
552 ;; ...), because part of the deal is that those only happen from
553 ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
554 ;; class. An invalid layout of T needs to be flushed, however.
555 (when (eq (layout-invalid (class-wrapper class
)) t
)
556 (%force-cache-flushes class
))
557 (setf (ctor-class ctor
) class
)
558 (pushnew (make-weak-pointer ctor
) (plist-value class
'ctors
)
559 :test
#'eq
:key
#'weak-pointer-value
)
560 (multiple-value-bind (form locations names optimizedp
)
561 (constructor-function-form ctor
)
562 (setf (funcallable-instance-fun ctor
)
564 (let ((*compiling-optimized-constructor
* t
))
565 (handler-bind ((compiler-note #'muffle-warning
))
566 (compile nil
`(lambda ,names
,form
))))
568 (ctor-state ctor
) (if optimizedp
'optimized
'fallback
))))))
570 (defun install-optimized-allocator (ctor)
572 (let* ((class-or-name (ctor-class-or-name ctor
))
573 (class (ensure-class-finalized
574 (if (symbolp class-or-name
)
575 (find-class class-or-name
)
577 ;; We can have a class with an invalid layout here. Such a class
578 ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
579 ;; ...), because part of the deal is that those only happen from
580 ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
581 ;; class. An invalid layout of T needs to be flushed, however.
582 (when (eq (layout-invalid (class-wrapper class
)) t
)
583 (%force-cache-flushes class
))
584 (setf (ctor-class ctor
) class
)
585 (pushnew (make-weak-pointer ctor
) (plist-value class
'ctors
)
586 :test
#'eq
:key
#'weak-pointer-value
)
587 (multiple-value-bind (form optimizedp
)
588 (allocator-function-form ctor
)
589 (setf (funcallable-instance-fun ctor
)
590 (let ((*compiling-optimized-constructor
* t
))
591 (handler-bind ((compiler-note #'muffle-warning
))
593 (ctor-state ctor
) (if optimizedp
'optimized
'fallback
))))))
595 (defun allocator-function-form (ctor)
596 (let ((class (ctor-class ctor
)))
597 (if (and (not (structure-class-p class
))
598 (not (condition-class-p class
))
599 (singleton-p (compute-applicable-methods #'allocate-instance
602 (member (slot-definition-allocation x
)
603 '(:instance
:class
)))
604 (class-slots class
)))
605 (values (optimizing-allocator-generator ctor
) t
)
607 (declare #.
*optimize-speed
*
608 (notinline allocate-instance
))
609 (allocate-instance ,class
))
612 (defun constructor-function-form (ctor)
613 (let* ((class (ctor-class ctor
))
614 (proto (class-prototype class
))
615 (make-instance-methods
616 (compute-applicable-methods #'make-instance
(list class
)))
617 (allocate-instance-methods
618 (compute-applicable-methods #'allocate-instance
(list class
)))
619 ;; I stared at this in confusion for a while, thinking
620 ;; carefully about the possibility of the class prototype not
621 ;; being of sufficient discrimiating power, given the
622 ;; possibility of EQL-specialized methods on
623 ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given
624 ;; that this is a constructor optimization, the user doesn't
625 ;; yet have the instance to create a method with such an EQL
628 ;; There remains the (theoretical) possibility of someone
629 ;; coming along with code of the form
631 ;; (defmethod initialize-instance :before ((o foo) ...)
632 ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
634 ;; but probably we can afford not to worry about this too
635 ;; much for now. -- CSR, 2004-07-12
637 (compute-applicable-methods #'initialize-instance
(list proto
)))
639 (compute-applicable-methods #'shared-initialize
(list proto t
)))
641 (loop for slot in
(class-slots class
)
642 when
(cdr (compute-applicable-methods
643 #'(setf slot-value-using-class
)
644 (list nil class proto slot
)))
647 (loop for slot in
(class-slots class
)
648 when
(cdr (compute-applicable-methods
649 #'slot-boundp-using-class
650 (list class proto slot
)))
652 ;; Cannot initialize these variables earlier because the generic
653 ;; functions don't exist when PCL is built.
654 (when (null *the-system-si-method
*)
655 (setq *the-system-si-method
*
656 (find-method #'shared-initialize
657 () (list *the-class-slot-object
* *the-class-t
*)))
658 (setq *the-system-ii-method
*
659 (find-method #'initialize-instance
660 () (list *the-class-slot-object
*))))
661 ;; Note that when there are user-defined applicable methods on
662 ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
663 ;; together with the system-defined ones in what
664 ;; COMPUTE-APPLICABLE-METHODS returns.
665 (let ((maybe-invalid-initargs
669 (ctor-default-initkeys
670 (ctor-initargs ctor
) (class-default-initargs class
))
671 (plist-keys (ctor-initargs ctor
)))
672 (append ii-methods si-methods
) nil nil
))
673 (custom-make-instance
674 (not (null (cdr make-instance-methods
)))))
675 (if (and (not (structure-class-p class
))
676 (not (condition-class-p class
))
677 (not custom-make-instance
)
678 (null (cdr allocate-instance-methods
))
680 (member (slot-definition-allocation x
)
681 '(:instance
:class
)))
683 (not maybe-invalid-initargs
)
684 (not (hairy-around-or-nonstandard-primary-method-p
685 ii-methods
*the-system-ii-method
*))
686 (not (around-or-nonstandard-primary-method-p
687 si-methods
*the-system-si-method
*)))
688 (optimizing-generator ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
689 (fallback-generator ctor ii-methods si-methods
690 (or maybe-invalid-initargs custom-make-instance
))))))
692 (defun around-or-nonstandard-primary-method-p
693 (methods &optional standard-method
)
694 (loop with primary-checked-p
= nil
695 for method in methods
696 as qualifiers
= (if (consp method
)
697 (early-method-qualifiers method
)
698 (safe-method-qualifiers method
))
699 when
(or (eq :around
(car qualifiers
))
700 (and (null qualifiers
)
701 (not primary-checked-p
)
702 (not (null standard-method
))
703 (not (eq standard-method method
))))
705 when
(null qualifiers
) do
706 (setq primary-checked-p t
)))
708 (defun hairy-around-or-nonstandard-primary-method-p
709 (methods &optional standard-method
)
710 (loop with primary-checked-p
= nil
711 for method in methods
712 as qualifiers
= (if (consp method
)
713 (early-method-qualifiers method
)
714 (safe-method-qualifiers method
))
715 when
(or (and (eq :around
(car qualifiers
))
716 (not (simple-next-method-call-p method
)))
717 (and (null qualifiers
)
718 (not primary-checked-p
)
719 (not (null standard-method
))
720 (not (eq standard-method method
))))
722 when
(null qualifiers
) do
723 (setq primary-checked-p t
)))
725 (defun fallback-generator (ctor ii-methods si-methods use-make-instance
)
726 (declare (ignore ii-methods si-methods
))
727 (let ((class (ctor-class ctor
))
728 (lambda-list (make-ctor-parameter-list ctor
))
729 (initargs (ctor-initargs ctor
)))
730 (if use-make-instance
731 `(lambda ,lambda-list
732 (declare #.
*optimize-speed
*)
733 ;; The CTOR MAKE-INSTANCE optimization checks for
734 ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
735 ;; compilation of the constructor, hence avoiding the
736 ;; possibility of endless recursion.
737 (make-instance ,class
,@(quote-plist-keys initargs
)))
738 (let ((defaults (class-default-initargs class
)))
740 (setf initargs
(ctor-default-initargs initargs defaults
)))
741 `(lambda ,lambda-list
742 (declare #.
*optimize-speed
*)
743 (fast-make-instance ,class
,@(quote-plist-keys initargs
)))))))
745 ;;; Not as good as the real optimizing generator, but faster than going
746 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
747 (defun fast-make-instance (class &rest initargs
)
748 (declare #.
*optimize-speed
*)
749 (declare (dynamic-extent initargs
))
750 (let ((.instance.
(apply #'allocate-instance class initargs
)))
751 (apply #'initialize-instance .instance. initargs
)
754 (defun optimizing-generator
755 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
756 (multiple-value-bind (locations names body early-unbound-markers-p
)
757 (fake-initialization-emf ctor ii-methods si-methods
758 setf-svuc-slots sbuc-slots
)
759 (let ((wrapper (class-wrapper (ctor-class ctor
))))
761 `(lambda ,(make-ctor-parameter-list ctor
)
762 (declare #.
*optimize-speed
*)
764 (when (layout-invalid ,wrapper
)
765 (install-initial-constructor ,ctor
)
766 (return (funcall ,ctor
,@(make-ctor-parameter-list ctor
))))
767 ,(wrap-in-allocate-forms ctor body early-unbound-markers-p
)))
772 (defun optimizing-allocator-generator
774 (let ((wrapper (class-wrapper (ctor-class ctor
))))
776 (declare #.
*optimize-speed
*)
778 (when (layout-invalid ,wrapper
)
779 (install-initial-constructor ,ctor
)
780 (return (funcall ,ctor
)))
781 ,(wrap-in-allocate-forms ctor nil t
)))))
783 ;;; Return a form wrapped around BODY that allocates an instance constructed
784 ;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we
785 ;;; have explicitly initialized them, requiring all slots to start as
786 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables .INSTANCE. to
787 ;;; the instance, and .SLOTS. to the instance's slot vector around BODY.
788 (defun wrap-in-allocate-forms (ctor body early-unbound-markers-p
)
789 (let* ((class (ctor-class ctor
))
790 (wrapper (class-wrapper class
))
791 (allocation-function (raw-instance-allocator class
))
792 (slots-fetcher (slots-fetcher class
)))
793 (if (eq allocation-function
'allocate-standard-instance
)
794 `(let ((.instance.
(%make-standard-instance nil
0))
796 ,(layout-length wrapper
)
797 ,@(when early-unbound-markers-p
798 '(:initial-element
+slot-unbound
+)))))
799 (setf (std-instance-wrapper .instance.
) ,wrapper
)
800 (setf (std-instance-slots .instance.
) .slots.
)
803 `(let* ((.instance.
(,allocation-function
,wrapper
))
804 (.slots.
(,slots-fetcher .instance.
)))
805 (declare (ignorable .slots.
))
809 ;;; Return a form for invoking METHOD with arguments from ARGS. As
810 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
811 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could
812 ;;; call fast method functions directly here, but benchmarks show that
813 ;;; there's no speed to gain, so lets avoid the hair here.
814 (defmacro invoke-method
(method args
&optional next-methods
)
815 `(funcall ,(the function
(method-function method
)) ,args
,next-methods
))
817 ;;; Return a form that is sort of an effective method comprising all
818 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
819 ;;; normally have taken place when calling MAKE-INSTANCE.
820 (defun fake-initialization-emf
821 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots
)
822 (multiple-value-bind (ii-around ii-before ii-primary ii-after
)
823 (standard-sort-methods ii-methods
)
824 (declare (ignore ii-primary
))
825 (multiple-value-bind (si-around si-before si-primary si-after
)
826 (standard-sort-methods si-methods
)
827 (declare (ignore si-primary
))
828 (aver (null si-around
))
829 (let ((initargs (ctor-initargs ctor
))
830 ;; :BEFORE and :AROUND initialization methods, and SETF SVUC and
831 ;; SBUC methods can cause slots to be accessed before the we have
832 ;; touched them here, which requires the instance-vector to be
833 ;; initialized with +SLOT-UNBOUND+ to start with.
834 (early-unbound-markers-p (or ii-before si-before ii-around
835 setf-svuc-slots sbuc-slots
)))
837 (locations names bindings vars defaulting-initargs body
)
838 (slot-init-forms ctor
839 early-unbound-markers-p
840 setf-svuc-slots sbuc-slots
)
845 (declare (ignorable ,@vars
))
846 (flet ((initialize-it (.ii-args. .next-methods.
)
847 ;; This has all the :BEFORE and :AFTER methods,
848 ;; and BODY does what primary SI method would do.
849 (declare (ignore .next-methods.
))
850 (let* ((.instance.
(car .ii-args.
))
851 ,@(when (or si-before si-after
)
853 (list* .instance. t
(cdr .ii-args.
))))))
854 ,@(loop for method in ii-before
855 collect
`(invoke-method ,method .ii-args.
))
856 ,@(loop for method in si-before
857 collect
`(invoke-method ,method .si-args.
))
859 ,@(loop for method in si-after
860 collect
`(invoke-method ,method .si-args.
))
861 ,@(loop for method in ii-after
862 collect
`(invoke-method ,method .ii-args.
))
864 (declare (dynamic-extent #'initialize-it
))
866 ,@(if (or ii-before ii-after ii-around si-before si-after
)
867 `((list .instance.
,@(quote-plist-keys initargs
)
868 ,@defaulting-initargs
))
869 `((list .instance.
)))))
871 ;; If there are :AROUND methods, call them first -- they get
872 ;; the normal chaining, with #'INITIALIZE-IT standing in for
874 `(let ((.next-methods.
875 (list ,@(cdr ii-around
) #'initialize-it
)))
876 (declare (dynamic-extent .next-methods.
))
877 (invoke-method ,(car ii-around
) .ii-args. .next-methods.
))
879 `(initialize-it .ii-args. nil
)))))
880 early-unbound-markers-p
))))))
882 ;;; Return four values from APPLICABLE-METHODS: around methods, before
883 ;;; methods, the applicable primary method, and applicable after
884 ;;; methods. Before and after methods are sorted in the order they
886 (defun standard-sort-methods (applicable-methods)
887 (loop for method in applicable-methods
888 as qualifiers
= (if (consp method
)
889 (early-method-qualifiers method
)
890 (safe-method-qualifiers method
))
892 collect method into primary
893 else if
(eq :around
(car qualifiers
))
894 collect method into around
895 else if
(eq :after
(car qualifiers
))
896 collect method into after
897 else if
(eq :before
(car qualifiers
))
898 collect method into before
900 (return (values around before
(first primary
) (reverse after
)))))
902 (defmacro with-type-checked
((type safe-p
) &body body
)
904 ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
905 ;; THE instead of e.g. CHECK-TYPE.
907 (declare (optimize (safety 3)))
908 (the ,type
(progn ,@body
)))
911 ;;; Return as multiple values bindings for default initialization arguments,
912 ;;; variable names, defaulting initargs and a body for initializing instance
913 ;;; and class slots of an object costructed by CTOR. The variable .SLOTS. is
914 ;;; assumed to bound to the instance's slot vector. EARLY-UNBOUND-MARKERS-P
915 ;;; means other code will initialize instance slots to +SLOT-UNBOUND+, and we
916 ;;; have to check if something has already set slots before we initialize
918 (defun slot-init-forms (ctor early-unbound-markers-p setf-svuc-slots sbuc-slots
)
919 (let* ((class (ctor-class ctor
))
920 (initargs (ctor-initargs ctor
))
921 (initkeys (plist-keys initargs
))
922 (safe-p (ctor-safe-p ctor
))
923 (wrapper (class-wrapper class
))
925 (make-array (layout-length wrapper
) :initial-element nil
))
928 (defaulting-initargs ())
929 (default-initargs (class-default-initargs class
))
931 (compute-initarg-locations
932 class
(append initkeys
(mapcar #'car default-initargs
)))))
933 (labels ((initarg-locations (initarg)
934 (cdr (assoc initarg initarg-locations
:test
#'eq
)))
935 (initializedp (location)
938 (assoc location class-inits
:test
#'eq
))
940 (not (null (aref slot-vector location
))))
941 (t (bug "Weird location in ~S" 'slot-init-forms
))))
942 (class-init (location kind val type slotd
)
943 (aver (consp location
))
944 (unless (initializedp location
)
945 (push (list location kind val type slotd
) class-inits
)))
946 (instance-init (location kind val type slotd
)
947 (aver (integerp location
))
948 (unless (initializedp location
)
949 (setf (aref slot-vector location
)
950 (list kind val type slotd
))))
951 (default-init-var-name (i)
952 (format-symbol *pcl-package
* ".D~D." i
))
953 (location-var-name (i)
954 (format-symbol *pcl-package
* ".L~D." i
)))
955 ;; Loop over supplied initargs and values and record which
956 ;; instance and class slots they initialize.
957 (loop for
(key value
) on initargs by
#'cddr
958 as kind
= (if (constantp value
) 'constant
'param
)
959 as locations
= (initarg-locations key
)
960 do
(loop for
(location type slotd
) in locations
961 do
(if (consp location
)
962 (class-init location kind value type slotd
)
963 (instance-init location kind value type slotd
))))
964 ;; Loop over default initargs of the class, recording
965 ;; initializations of slots that have not been initialized
966 ;; above. Default initargs which are not in the supplied
967 ;; initargs are treated as if they were appended to supplied
968 ;; initargs, that is, their values must be evaluated even
969 ;; if not actually used for initializing a slot.
970 (loop for
(key initform initfn
) in default-initargs and i from
0
971 unless
(member key initkeys
:test
#'eq
)
972 do
(let* ((kind (if (constantp initform
) 'constant
'var
))
973 (init (if (eq kind
'var
) initfn initform
)))
976 (push (list 'quote key
) defaulting-initargs
)
977 (push initform defaulting-initargs
))
979 (push (list 'quote key
) defaulting-initargs
)
980 (push (default-init-var-name i
) defaulting-initargs
)))
982 (let ((init-var (default-init-var-name i
)))
984 (push (cons init-var initfn
) default-inits
)))
985 (loop for
(location type slotd
) in
(initarg-locations key
)
986 do
(if (consp location
)
987 (class-init location kind init type slotd
)
988 (instance-init location kind init type slotd
)))))
989 ;; Loop over all slots of the class, filling in the rest from
991 (loop for slotd in
(class-slots class
)
992 as location
= (slot-definition-location slotd
)
993 as type
= (slot-definition-type slotd
)
994 as allocation
= (slot-definition-allocation slotd
)
995 as initfn
= (slot-definition-initfunction slotd
)
996 as initform
= (slot-definition-initform slotd
) do
997 (unless (or (eq allocation
:class
)
999 (initializedp location
))
1000 (if (constantp initform
)
1001 (instance-init location
'initform initform type slotd
)
1002 (instance-init location
1003 'initform
/initfn initfn type slotd
))))
1004 ;; Generate the forms for initializing instance and class slots.
1005 (let ((instance-init-forms
1006 (loop for slot-entry across slot-vector and i from
0
1007 as
(kind value type slotd
) = slot-entry
1009 (flet ((setf-form (value-form)
1010 (if (member slotd setf-svuc-slots
:test
#'eq
)
1011 `(setf (slot-value-using-class
1012 ,class .instance.
,slotd
)
1014 `(setf (clos-slots-ref .slots.
,i
)
1015 (with-type-checked (,type
,safe-p
)
1018 (if (member slotd sbuc-slots
:test
#'eq
)
1019 `(not (slot-boundp-using-class
1020 ,class .instance.
,slotd
))
1021 `(eq (clos-slots-ref .slots.
,i
)
1025 (unless early-unbound-markers-p
1026 `(setf (clos-slots-ref .slots.
,i
)
1031 (setf-form `(funcall ,value
)))
1033 (if early-unbound-markers-p
1034 `(when ,(not-boundp-form)
1035 ,(setf-form `(funcall ,value
)))
1036 (setf-form `(funcall ,value
))))
1038 (if early-unbound-markers-p
1039 `(when ,(not-boundp-form)
1040 ,(setf-form `',(constant-form-value value
)))
1041 (setf-form `',(constant-form-value value
))))
1043 (setf-form `',(constant-form-value value
))))))))
1044 ;; we are not allowed to modify QUOTEd locations, so we can't
1045 ;; generate code like (setf (cdr ',location) arg). Instead,
1046 ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
1047 ;; be bound to the location.
1048 (multiple-value-bind (names locations class-init-forms
)
1052 for
(location kind value type slotd
) in class-inits
1055 (constant `',(constant-form-value value
))
1056 ((param var
) `,value
)
1057 (initfn `(funcall ,value
)))
1058 when
(member slotd setf-svuc-slots
:test
#'eq
)
1059 collect
`(setf (slot-value-using-class
1060 ,class .instance.
,slotd
)
1062 into class-init-forms
1064 (let ((name (location-var-name (incf i
))))
1066 (push location locations
)
1068 (with-type-checked (,type
,safe-p
)
1070 into class-init-forms
1071 finally
(return (values (nreverse names
)
1072 (nreverse locations
)
1074 (multiple-value-bind (vars bindings
)
1075 (loop for
(var . initfn
) in
(nreverse default-inits
)
1076 collect var into vars
1077 collect
`(,var
(funcall ,initfn
)) into bindings
1078 finally
(return (values vars bindings
)))
1079 (values locations names
1081 (nreverse defaulting-initargs
)
1082 `(,@(delete nil instance-init-forms
)
1083 ,@class-init-forms
))))))))
1085 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
1086 ;;; telling, for each key in INITKEYS, which locations the initarg
1087 ;;; initializes and the associated type with the location. CLASS is
1088 ;;; the class of the instance being initialized.
1089 (defun compute-initarg-locations (class initkeys
)
1090 (loop with slots
= (class-slots class
)
1091 for key in initkeys collect
1092 (loop for slot in slots
1093 if
(memq key
(slot-definition-initargs slot
))
1094 collect
(list (slot-definition-location slot
)
1095 (slot-definition-type slot
)
1099 collect slot into remaining-slots
1101 (setq slots remaining-slots
)
1102 (return (cons key locations
)))))
1105 ;;; *******************************
1106 ;;; External Entry Points ********
1107 ;;; *******************************
1109 (defun update-ctors (reason &key class name generic-function method
)
1110 (labels ((reset (class &optional initarg-caches-p
(ctorsp t
))
1112 (setf (plist-value class
'ctors
)
1115 (let ((ctor (weak-pointer-value weak
)))
1117 (install-initial-constructor ctor
)
1120 (plist-value class
'ctors
))))
1121 (when initarg-caches-p
1122 (dolist (cache '(mi-initargs ri-initargs
))
1123 (setf (plist-value class cache
) ())))
1124 (dolist (subclass (class-direct-subclasses class
))
1125 (reset subclass initarg-caches-p ctorsp
))))
1127 ;; CLASS must have been specified.
1128 (finalize-inheritance
1130 ;; NAME must have been specified.
1132 (loop for ctor being the hash-values of
*all-ctors
*
1133 when
(eq (ctor-class-or-name ctor
) name
)
1135 (when (ctor-class ctor
)
1136 (reset (ctor-class ctor
)))
1138 ;; GENERIC-FUNCTION and METHOD must have been specified.
1139 ((add-method remove-method
)
1140 (flet ((class-of-1st-method-param (method)
1141 (type-class (first (method-specializers method
)))))
1142 (case (generic-function-name generic-function
)
1143 ((make-instance allocate-instance
)
1144 ;; FIXME: I can't see a way of working out which classes a
1145 ;; given metaclass specializer are applicable to short of
1146 ;; iterating and testing with class-of. It would be good
1147 ;; to not invalidate caches of system classes at this
1148 ;; point (where it is not legal to define a method
1149 ;; applicable to them on system functions). -- CSR,
1151 (reset (find-class 'standard-object
) t t
))
1152 ((initialize-instance shared-initialize
)
1153 (reset (class-of-1st-method-param method
) t t
))
1154 ((reinitialize-instance)
1155 (reset (class-of-1st-method-param method
) t nil
))
1156 (t (when (or (eq (generic-function-name generic-function
)
1157 'slot-boundp-using-class
)
1158 (equal (generic-function-name generic-function
)
1159 '(setf slot-value-using-class
)))
1160 ;; this looks awfully expensive, but given that one
1161 ;; can specialize on the SLOTD argument, nothing is
1162 ;; safe. -- CSR, 2004-07-12
1163 (reset (find-class 'standard-object
))))))))))
1165 (defun precompile-ctors ()
1166 (loop for ctor being the hash-values of
*all-ctors
*
1167 unless
(ctor-class ctor
)
1169 (let ((class (find-class (ctor-class-or-name ctor
) nil
)))
1170 (when (and class
(class-finalized-p class
))
1171 (install-optimized-constructor ctor
)))))
1173 (defun maybe-call-ctor (class initargs
)
1174 (flet ((frob-initargs (ctor)
1175 (do ((ctail (ctor-initargs ctor
))
1178 ((or (null ctail
) (null itail
))
1179 (values (nreverse args
) (and (null ctail
) (null itail
))))
1180 (unless (eq (pop ctail
) (pop itail
))
1182 (let ((cval (pop ctail
))
1184 (if (constantp cval
)
1185 (unless (eql cval ival
)
1187 (push ival args
))))))
1188 (dolist (weak (plist-value class
'ctors
))
1189 (let ((ctor (weak-pointer-value weak
)))
1191 (eq (ctor-type ctor
) 'ctor
)
1192 (eq (ctor-state ctor
) 'optimized
))
1193 (multiple-value-bind (ctor-args matchp
)
1194 (frob-initargs ctor
)
1196 (return (apply ctor ctor-args
)))))))))
1198 ;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
1199 (defun check-mi-initargs (class initargs
)
1200 (let* ((class-proto (class-prototype class
))
1201 (keys (plist-keys initargs
))
1202 (cache (plist-value class
'mi-initargs
))
1203 (cached (assoc keys cache
:test
#'equal
))
1210 (list (list* 'allocate-instance class initargs
)
1211 (list* 'initialize-instance class-proto initargs
)
1212 (list* 'shared-initialize class-proto t initargs
))
1214 (setf (plist-value class
'mi-initargs
)
1215 (acons keys invalid cache
))
1218 ;; FIXME: should have an operation here, and maybe a set of
1220 (error 'initarg-error
:class class
:initargs invalid-keys
))))
1222 (defun check-ri-initargs (instance initargs
)
1223 (let* ((class (class-of instance
))
1224 (keys (plist-keys initargs
))
1225 (cache (plist-value class
'ri-initargs
))
1226 (cached (assoc keys cache
:test
#'equal
))
1231 ;; FIXME: give CHECK-INITARGS-1 and friends a
1232 ;; more mnemonic name and (possibly) a nicer,
1233 ;; more orthogonal interface.
1236 (list (list* 'reinitialize-instance instance initargs
)
1237 (list* 'shared-initialize instance nil initargs
))
1239 (setf (plist-value class
'ri-initargs
)
1240 (acons keys invalid cache
))
1243 (error 'initarg-error
:class class
:initargs invalid-keys
))))
1245 ;;; end of ctor.lisp