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 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 (setf (funcallable-instance-fun ctor
)
147 #'(lambda (&rest args
)
148 (install-optimized-constructor ctor
)
150 (setf (%funcallable-instance-info ctor
1)
151 (ctor-function-name ctor
))))
153 (defun make-ctor-function-name (class-name initargs safe-code-p
)
154 (list* 'ctor class-name safe-code-p initargs
))
156 ;;; Keep this a separate function for testing.
157 (defun ensure-ctor (function-name class-name initargs safe-code-p
)
158 (unless (fboundp function-name
)
159 (make-ctor function-name class-name initargs safe-code-p
)))
161 ;;; Keep this a separate function for testing.
162 (defun make-ctor (function-name class-name initargs safe-p
)
163 (without-package-locks ; for (setf symbol-function)
164 (let ((ctor (%make-ctor function-name class-name nil initargs safe-p
)))
165 (push ctor
*all-ctors
*)
166 (setf (fdefinition function-name
) ctor
)
167 (install-initial-constructor ctor
:force-p t
)
170 ;;; *****************
171 ;;; Inline CTOR cache
172 ;;; *****************
174 ;;; The cache starts out as a list of CTORs, sorted with the most recently
175 ;;; used CTORs near the head. If it expands too much, we switch to a vector
176 ;;; with a simple hashing scheme.
178 ;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
179 ;;; is in the list but not one of the 4 first ones, return a new list with the
180 ;;; found CTOR at the head. Thread-safe: the new list shares structure with
181 ;;; the old, but is not desctructively modified. Returning the old list for
182 ;;; hits close to the head reduces ping-ponging with multiple threads seeking
184 (defun find-ctor (key list
)
185 (labels ((walk (tail from-head depth
)
186 (declare (fixnum depth
))
188 (let ((ctor (car tail
)))
189 (if (eq (ctor-class-or-name ctor
) key
)
192 (nconc (list ctor
) (nreverse from-head
) (cdr tail
)))
196 (cons ctor from-head
)
197 (logand #xf
(1+ depth
)))))
201 (declaim (inline sxhash-symbol-or-class
))
202 (defun sxhash-symbol-or-class (x)
203 (cond ((symbolp x
) (sxhash x
))
204 ((std-instance-p x
) (std-instance-hash x
))
205 ((fsc-instance-p x
) (fsc-instance-hash x
))
207 (bug "Something strange where symbol or class expected."))))
209 ;;; Max number of CTORs kept in an inline list cache. Once this is
210 ;;; exceeded we switch to a table.
211 (defconstant +ctor-list-max-size
+ 12)
212 ;;; Max table size for CTOR cache. If the table fills up at this size
213 ;;; we keep the same size and drop 50% of the old entries.
214 (defconstant +ctor-table-max-size
+ (expt 2 8))
215 ;;; Even if there is space in the cache, if we cannot fit a new entry
216 ;;; with max this number of collisions we expand the table (if possible)
218 (defconstant +ctor-table-max-probe-depth
+ 5)
220 (defun make-ctor-table (size)
221 (declare (index size
))
222 (let ((real-size (power-of-two-ceiling size
)))
223 (if (< real-size
+ctor-table-max-size
+)
224 (values (make-array real-size
:initial-element nil
) nil
)
225 (values (make-array +ctor-table-max-size
+ :initial-element nil
) t
))))
227 (declaim (inline mix-ctor-hash
))
228 (defun mix-ctor-hash (hash base
)
229 (logand most-positive-fixnum
(+ hash base
1)))
231 (defun put-ctor (ctor table
)
232 (cond ((try-put-ctor ctor table
)
235 (expand-ctor-table ctor table
))))
237 ;;; Thread-safe: if two threads write to the same index in parallel, the other
238 ;;; result is just lost. This is not an issue as the CTORs are used as their
239 ;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
240 ;;; one is needed we just cache it again -- hopefully not getting stomped on
242 (defun try-put-ctor (ctor table
)
243 (declare (simple-vector table
) (optimize speed
))
244 (let* ((class (ctor-class-or-name ctor
))
245 (base (sxhash-symbol-or-class class
))
247 (mask (1- (length table
))))
248 (declare (fixnum base hash mask
))
249 (loop repeat
+ctor-table-max-probe-depth
+
250 do
(let* ((index (logand mask hash
))
251 (old (aref table index
)))
252 (cond ((and old
(neq class
(ctor-class-or-name old
)))
253 (setf hash
(mix-ctor-hash hash base
)))
255 (setf (aref table index
) ctor
)
256 (return-from try-put-ctor t
)))))
257 ;; Didn't fit, must expand
260 (defun get-ctor (class table
)
261 (declare (simple-vector table
) (optimize speed
))
262 (let* ((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 (if (and old
(eq class
(ctor-class-or-name old
)))
270 (return-from get-ctor old
)
271 (setf hash
(mix-ctor-hash hash base
)))))
275 ;;; Thread safe: the old table is read, but if another thread mutates
276 ;;; it while we're reading we still get a sane result -- either the old
277 ;;; or the new entry. The new table is locally allocated, so that's ok
279 (defun expand-ctor-table (ctor old
)
280 (declare (simple-vector old
))
281 (let* ((old-size (length old
))
282 (new-size (* 2 old-size
))
283 (drop-random-entries nil
))
286 (multiple-value-bind (new max-size-p
) (make-ctor-table new-size
)
287 (let ((action (if drop-random-entries
288 ;; Same logic as in method caches -- see comment
290 (randomly-punting-lambda (old-ctor)
291 (try-put-ctor old-ctor new
))
293 (unless (try-put-ctor old-ctor new
)
295 (setf drop-random-entries t
)
296 (setf new-size
(* 2 new-size
)))
298 (aver (try-put-ctor ctor new
))
299 (dotimes (i old-size
)
300 (let ((old-ctor (aref old i
)))
302 (funcall action old-ctor
))))
303 (return-from expand-ctor-table
(values ctor new
)))))))
305 (defun ctor-list-to-table (list)
306 (let ((table (make-ctor-table (length list
))))
308 (setf table
(nth-value 1 (put-ctor ctor table
))))
311 (defun ctor-for-caching (class-name initargs safe-code-p
)
312 (let ((name (make-ctor-function-name class-name initargs safe-code-p
)))
313 (or (ensure-ctor name class-name initargs safe-code-p
)
314 (fdefinition name
))))
316 (defun ensure-cached-ctor (class-name store initargs safe-code-p
)
318 (multiple-value-bind (ctor list
) (find-ctor class-name store
)
321 (let ((ctor (ctor-for-caching class-name initargs safe-code-p
)))
322 (if (< (length list
) +ctor-list-max-size
+)
323 (values ctor
(cons ctor list
))
324 (values ctor
(ctor-list-to-table list
))))))
325 (let ((ctor (get-ctor class-name store
)))
328 (put-ctor (ctor-for-caching class-name initargs safe-code-p
)
331 ;;; ***********************************************
332 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
333 ;;; ***********************************************
335 (defvar *compiling-optimized-constructor
* nil
)
337 (define-compiler-macro make-instance
(&whole form
&rest args
&environment env
)
338 (declare (ignore args
))
339 ;; Compiling an optimized constructor for a non-standard class means compiling a
340 ;; lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it -- need
341 ;; to make sure we don't recurse there.
342 (or (unless *compiling-optimized-constructor
*
343 (make-instance->constructor-call form
(safe-code-p env
)))
346 (defun make-instance->constructor-call
(form safe-code-p
)
347 (destructuring-bind (class-arg &rest args
) (cdr form
)
349 ;; Return the name of parameter number I of a constructor
352 (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.
)))
353 (if (array-in-bounds-p ps i
)
355 (format-symbol *pcl-package
* ".P~D." i
))))
356 ;; Check if CLASS-ARG is a constant symbol. Give up if
359 (and class-arg
(constant-class-arg-p class-arg
)))
360 ;; Check if ARGS are suitable for an optimized constructor.
361 ;; Return NIL from the outer function if not.
363 (loop for
(key . more
) on args by
#'cddr do
364 (when (or (null more
)
365 (not (constant-symbol-p key
))
366 (eq :allow-other-keys
(constant-form-value key
)))
367 (return-from make-instance-
>constructor-call nil
)))))
369 ;; Collect a plist of initargs and constant values/parameter names
370 ;; in INITARGS. Collect non-constant initialization forms in
372 (multiple-value-bind (initargs value-forms
)
373 (loop for
(key value
) on args by
#'cddr and i from
0
374 collect
(constant-form-value key
) into initargs
376 collect value into initargs
378 collect
(parameter-name i
) into initargs
379 and collect value into value-forms
381 (return (values initargs value-forms
)))
382 (if (constant-class-p)
383 (let* ((class-or-name (constant-form-value class-arg
))
384 (function-name (make-ctor-function-name class-or-name initargs
386 ;; Prevent compiler warnings for calling the ctor.
387 (proclaim-as-fun-name function-name
)
388 (note-name-defined function-name
:function
)
389 (when (eq (info :function
:where-from function-name
) :assumed
)
390 (setf (info :function
:where-from function-name
) :defined
)
391 (when (info :function
:assumed-type function-name
)
392 (setf (info :function
:assumed-type function-name
) nil
)))
393 ;; Return code constructing a ctor at load time, which, when
394 ;; called, will set its funcallable instance function to an
395 ;; optimized constructor function.
397 (declare (disable-package-locks ,function-name
))
398 (let ((.x.
(load-time-value
399 (ensure-ctor ',function-name
',class-or-name
',initargs
401 (declare (ignore .x.
))
402 ;; ??? check if this is worth it.
404 (ftype (or (function ,(make-list (length value-forms
)
407 (function (&rest t
) t
))
409 (funcall (function ,function-name
) ,@value-forms
))))
411 ;; Build an inline cache: a CONS, with the actual cache in the CDR.
412 `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
414 (let* ((.cache.
(load-time-value (cons 'ctor-cache nil
)))
415 (.store.
(cdr .cache.
))
416 (.class-arg.
,class-arg
))
417 (multiple-value-bind (.fun. .new-store.
)
418 (ensure-cached-ctor .class-arg. .store.
',initargs
',safe-code-p
)
419 ;; Thread safe: if multiple threads hit this in paralle, the update
420 ;; from the other one is just lost -- no harm done, except for the
421 ;; need to redo the work next time.
422 (unless (eq .store. .new-store.
)
423 (setf (cdr .cache.
) .new-store.
))
424 (funcall (truly-the function .fun.
) ,@value-forms
))))))))))
426 ;;; **************************************************
427 ;;; Load-Time Constructor Function Generation *******
428 ;;; **************************************************
430 ;;; The system-supplied primary INITIALIZE-INSTANCE and
431 ;;; SHARED-INITIALIZE methods. One cannot initialize these variables
432 ;;; to the right values here because said functions don't exist yet
433 ;;; when this file is first loaded.
434 (defvar *the-system-ii-method
* nil
)
435 (defvar *the-system-si-method
* nil
)
437 (defun install-optimized-constructor (ctor)
439 (let* ((class-or-name (ctor-class-or-name ctor
))
440 (class (if (symbolp class-or-name
)
441 (find-class class-or-name
)
443 (unless (class-finalized-p class
)
444 (finalize-inheritance class
))
445 ;; We can have a class with an invalid layout here. Such a class
446 ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
447 ;; ...), because part of the deal is that those only happen from
448 ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
449 ;; class. An invalid layout of T needs to be flushed, however.
450 (when (eq (layout-invalid (class-wrapper class
)) t
)
451 (%force-cache-flushes class
))
452 (setf (ctor-class ctor
) class
)
453 (pushnew ctor
(plist-value class
'ctors
) :test
#'eq
)
454 (setf (funcallable-instance-fun ctor
)
455 (multiple-value-bind (form locations names
)
456 (constructor-function-form ctor
)
458 (let ((*compiling-optimized-constructor
* t
))
459 (handler-bind ((compiler-note #'muffle-warning
))
460 (compile nil
`(lambda ,names
,form
))))
463 (defun constructor-function-form (ctor)
464 (let* ((class (ctor-class ctor
))
465 (proto (class-prototype class
))
466 (make-instance-methods
467 (compute-applicable-methods #'make-instance
(list class
)))
468 (allocate-instance-methods
469 (compute-applicable-methods #'allocate-instance
(list class
)))
470 ;; I stared at this in confusion for a while, thinking
471 ;; carefully about the possibility of the class prototype not
472 ;; being of sufficient discrimiating power, given the
473 ;; possibility of EQL-specialized methods on
474 ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given
475 ;; that this is a constructor optimization, the user doesn't
476 ;; yet have the instance to create a method with such an EQL
479 ;; There remains the (theoretical) possibility of someone
480 ;; coming along with code of the form
482 ;; (defmethod initialize-instance :before ((o foo) ...)
483 ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
485 ;; but probably we can afford not to worry about this too
486 ;; much for now. -- CSR, 2004-07-12
488 (compute-applicable-methods #'initialize-instance
(list proto
)))
490 (compute-applicable-methods #'shared-initialize
(list proto t
)))
491 (setf-svuc-slots-methods
492 (loop for slot in
(class-slots class
)
493 collect
(compute-applicable-methods
494 #'(setf slot-value-using-class
)
495 (list nil class proto slot
))))
497 (loop for slot in
(class-slots class
)
498 collect
(compute-applicable-methods
499 #'slot-boundp-using-class
500 (list class proto slot
)))))
501 ;; Cannot initialize these variables earlier because the generic
502 ;; functions don't exist when PCL is built.
503 (when (null *the-system-si-method
*)
504 (setq *the-system-si-method
*
505 (find-method #'shared-initialize
506 () (list *the-class-slot-object
* *the-class-t
*)))
507 (setq *the-system-ii-method
*
508 (find-method #'initialize-instance
509 () (list *the-class-slot-object
*))))
510 ;; Note that when there are user-defined applicable methods on
511 ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
512 ;; together with the system-defined ones in what
513 ;; COMPUTE-APPLICABLE-METHODS returns.
514 (let ((maybe-invalid-initargs
518 (ctor-default-initkeys
519 (ctor-initargs ctor
) (class-default-initargs class
))
520 (plist-keys (ctor-initargs ctor
)))
521 (append ii-methods si-methods
) nil nil
))
522 (custom-make-instance
523 (not (null (cdr make-instance-methods
)))))
524 (if (and (not (structure-class-p class
))
525 (not (condition-class-p class
))
526 (not custom-make-instance
)
527 (null (cdr allocate-instance-methods
))
529 (member (slot-definition-allocation x
)
530 '(:instance
:class
)))
532 (not maybe-invalid-initargs
)
533 (not (around-or-nonstandard-primary-method-p
534 ii-methods
*the-system-ii-method
*))
535 (not (around-or-nonstandard-primary-method-p
536 si-methods
*the-system-si-method
*))
537 ;; the instance structure protocol goes through
538 ;; slot-value(-using-class) and friends (actually just
539 ;; (SETF SLOT-VALUE-USING-CLASS) and
540 ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
541 ;; applicable methods we can't shortcircuit them.
542 (every (lambda (x) (= (length x
) 1)) setf-svuc-slots-methods
)
543 (every (lambda (x) (= (length x
) 1)) sbuc-slots-methods
))
544 (optimizing-generator ctor ii-methods si-methods
)
545 (fallback-generator ctor ii-methods si-methods
546 (or maybe-invalid-initargs custom-make-instance
))))))
548 (defun around-or-nonstandard-primary-method-p
549 (methods &optional standard-method
)
550 (loop with primary-checked-p
= nil
551 for method in methods
552 as qualifiers
= (if (consp method
)
553 (early-method-qualifiers method
)
554 (safe-method-qualifiers method
))
555 when
(or (eq :around
(car qualifiers
))
556 (and (null qualifiers
)
557 (not primary-checked-p
)
558 (not (null standard-method
))
559 (not (eq standard-method method
))))
561 when
(null qualifiers
) do
562 (setq primary-checked-p t
)))
564 (defun fallback-generator (ctor ii-methods si-methods use-make-instance
)
565 (declare (ignore ii-methods si-methods
))
566 (let ((class (ctor-class ctor
))
567 (lambda-list (make-ctor-parameter-list ctor
))
568 (initargs (quote-plist-keys (ctor-initargs ctor
))))
569 (if use-make-instance
570 `(lambda ,lambda-list
571 (declare #.
*optimize-speed
*)
572 ;; The CTOR MAKE-INSTANCE optimization checks for
573 ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around compilation of
574 ;; the constructor, hence avoiding the possibility of endless recursion.
575 (make-instance ,class
,@initargs
))
576 (let ((defaults (class-default-initargs class
)))
578 (setf initargs
(ctor-default-initargs initargs defaults
)))
579 `(lambda ,lambda-list
580 (declare #.
*optimize-speed
*)
581 (fast-make-instance ,class
,@initargs
))))))
583 ;;; Not as good as the real optimizing generator, but faster than going
584 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
585 (defun fast-make-instance (class &rest initargs
)
586 (declare #.
*optimize-speed
*)
587 (declare (dynamic-extent initargs
))
588 (let ((.instance.
(apply #'allocate-instance class initargs
)))
589 (apply #'initialize-instance .instance. initargs
)
592 (defun optimizing-generator (ctor ii-methods si-methods
)
593 (multiple-value-bind (locations names body before-method-p
)
594 (fake-initialization-emf ctor ii-methods si-methods
)
595 (let ((wrapper (class-wrapper (ctor-class ctor
))))
597 `(lambda ,(make-ctor-parameter-list ctor
)
598 (declare #.
*optimize-speed
*)
600 (when (layout-invalid ,wrapper
)
601 (install-initial-constructor ,ctor
)
602 (return (funcall ,ctor
,@(make-ctor-parameter-list ctor
))))
603 ,(wrap-in-allocate-forms ctor body before-method-p
)))
607 ;;; Return a form wrapped around BODY that allocates an instance
608 ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
609 ;;; before-methods, in which case we initialize instance slots to
610 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables
611 ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot
612 ;;; vector around BODY.
613 (defun wrap-in-allocate-forms (ctor body before-method-p
)
614 (let* ((class (ctor-class ctor
))
615 (wrapper (class-wrapper class
))
616 (allocation-function (raw-instance-allocator class
))
617 (slots-fetcher (slots-fetcher class
)))
618 (if (eq allocation-function
'allocate-standard-instance
)
619 `(let ((.instance.
(%make-standard-instance nil
620 (get-instance-hash-code)))
622 ,(layout-length wrapper
)
623 ,@(when before-method-p
624 '(:initial-element
+slot-unbound
+)))))
625 (setf (std-instance-wrapper .instance.
) ,wrapper
)
626 (setf (std-instance-slots .instance.
) .slots.
)
629 `(let* ((.instance.
(,allocation-function
,wrapper
))
630 (.slots.
(,slots-fetcher .instance.
)))
631 (declare (ignorable .slots.
))
635 ;;; Return a form for invoking METHOD with arguments from ARGS. As
636 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
637 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could
638 ;;; call fast method functions directly here, but benchmarks show that
639 ;;; there's no speed to gain, so lets avoid the hair here.
640 (defmacro invoke-method
(method args
)
641 `(funcall ,(method-function method
) ,args
()))
643 ;;; Return a form that is sort of an effective method comprising all
644 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
645 ;;; normally have taken place when calling MAKE-INSTANCE.
646 (defun fake-initialization-emf (ctor ii-methods si-methods
)
647 (multiple-value-bind (ii-around ii-before ii-primary ii-after
)
648 (standard-sort-methods ii-methods
)
649 (declare (ignore ii-primary
))
650 (multiple-value-bind (si-around si-before si-primary si-after
)
651 (standard-sort-methods si-methods
)
652 (declare (ignore si-primary
))
653 (aver (and (null ii-around
) (null si-around
)))
654 (let ((initargs (ctor-initargs ctor
)))
655 (multiple-value-bind (locations names bindings vars defaulting-initargs body
)
656 (slot-init-forms ctor
(or ii-before si-before
))
661 (declare (ignorable ,@vars
))
662 (let (,@(when (or ii-before ii-after
)
664 (list .instance.
,@(quote-plist-keys initargs
) ,@defaulting-initargs
))))
665 ,@(when (or si-before si-after
)
667 (list .instance. t
,@(quote-plist-keys initargs
) ,@defaulting-initargs
)))))
668 ,@(loop for method in ii-before
669 collect
`(invoke-method ,method .ii-args.
))
670 ,@(loop for method in si-before
671 collect
`(invoke-method ,method .si-args.
))
673 ,@(loop for method in si-after
674 collect
`(invoke-method ,method .si-args.
))
675 ,@(loop for method in ii-after
676 collect
`(invoke-method ,method .ii-args.
))))
677 (or ii-before si-before
)))))))
679 ;;; Return four values from APPLICABLE-METHODS: around methods, before
680 ;;; methods, the applicable primary method, and applicable after
681 ;;; methods. Before and after methods are sorted in the order they
683 (defun standard-sort-methods (applicable-methods)
684 (loop for method in applicable-methods
685 as qualifiers
= (if (consp method
)
686 (early-method-qualifiers method
)
687 (safe-method-qualifiers method
))
689 collect method into primary
690 else if
(eq :around
(car qualifiers
))
691 collect method into around
692 else if
(eq :after
(car qualifiers
))
693 collect method into after
694 else if
(eq :before
(car qualifiers
))
695 collect method into before
697 (return (values around before
(first primary
) (reverse after
)))))
699 (defmacro with-type-checked
((type safe-p
) &body body
)
701 ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
702 ;; THE instead of e.g. CHECK-TYPE.
704 (declare (optimize (safety 3)))
705 (the ,type
(progn ,@body
)))
708 ;;; Return as multiple values bindings for default initialization
709 ;;; arguments, variable names, defaulting initargs and a body for
710 ;;; initializing instance and class slots of an object costructed by
711 ;;; CTOR. The variable .SLOTS. is assumed to bound to the instance's
712 ;;; slot vector. BEFORE-METHOD-P T means before-methods will be
713 ;;; called, which means that 1) other code will initialize instance
714 ;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and
715 ;;; that we have to check if these before-methods have set slots.
716 (defun slot-init-forms (ctor before-method-p
)
717 (let* ((class (ctor-class ctor
))
718 (initargs (ctor-initargs ctor
))
719 (initkeys (plist-keys initargs
))
720 (safe-p (ctor-safe-p ctor
))
722 (make-array (layout-length (class-wrapper class
))
723 :initial-element nil
))
726 (defaulting-initargs ())
727 (default-initargs (class-default-initargs class
))
729 (compute-initarg-locations
730 class
(append initkeys
(mapcar #'car default-initargs
)))))
731 (labels ((initarg-locations (initarg)
732 (cdr (assoc initarg initarg-locations
:test
#'eq
)))
733 (initializedp (location)
736 (assoc location class-inits
:test
#'eq
))
738 (not (null (aref slot-vector location
))))
739 (t (bug "Weird location in ~S" 'slot-init-forms
))))
740 (class-init (location kind val type
)
741 (aver (consp location
))
742 (unless (initializedp location
)
743 (push (list location kind val type
) class-inits
)))
744 (instance-init (location kind val type
)
745 (aver (integerp location
))
746 (unless (initializedp location
)
747 (setf (aref slot-vector location
) (list kind val type
))))
748 (default-init-var-name (i)
749 (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.
)))
750 (if (array-in-bounds-p ps i
)
752 (format-symbol *pcl-package
* ".D~D." i
))))
753 (location-var-name (i)
754 (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.
)))
755 (if (array-in-bounds-p ls i
)
757 (format-symbol *pcl-package
* ".L~D." i
)))))
758 ;; Loop over supplied initargs and values and record which
759 ;; instance and class slots they initialize.
760 (loop for
(key value
) on initargs by
#'cddr
761 as kind
= (if (constantp value
) 'constant
'param
)
762 as locations
= (initarg-locations key
)
763 do
(loop for
(location . type
) in locations
764 do
(if (consp location
)
765 (class-init location kind value type
)
766 (instance-init location kind value type
))))
767 ;; Loop over default initargs of the class, recording
768 ;; initializations of slots that have not been initialized
769 ;; above. Default initargs which are not in the supplied
770 ;; initargs are treated as if they were appended to supplied
771 ;; initargs, that is, their values must be evaluated even
772 ;; if not actually used for initializing a slot.
773 (loop for
(key initform initfn
) in default-initargs and i from
0
774 unless
(member key initkeys
:test
#'eq
)
775 do
(let* ((kind (if (constantp initform
) 'constant
'var
))
776 (init (if (eq kind
'var
) initfn initform
)))
779 (push (list 'quote key
) defaulting-initargs
)
780 (push initform defaulting-initargs
))
782 (push (list 'quote key
) defaulting-initargs
)
783 (push (default-init-var-name i
) defaulting-initargs
)))
785 (let ((init-var (default-init-var-name i
)))
787 (push (cons init-var initfn
) default-inits
)))
788 (loop for
(location . type
) in
(initarg-locations key
)
789 do
(if (consp location
)
790 (class-init location kind init type
)
791 (instance-init location kind init type
)))))
792 ;; Loop over all slots of the class, filling in the rest from
794 (loop for slotd in
(class-slots class
)
795 as location
= (slot-definition-location slotd
)
796 as type
= (slot-definition-type slotd
)
797 as allocation
= (slot-definition-allocation slotd
)
798 as initfn
= (slot-definition-initfunction slotd
)
799 as initform
= (slot-definition-initform slotd
) do
800 (unless (or (eq allocation
:class
)
802 (initializedp location
))
803 (if (constantp initform
)
804 (instance-init location
'initform initform type
)
805 (instance-init location
'initform
/initfn initfn type
))))
806 ;; Generate the forms for initializing instance and class slots.
807 (let ((instance-init-forms
808 (loop for slot-entry across slot-vector and i from
0
809 as
(kind value type
) = slot-entry collect
812 (unless before-method-p
813 `(setf (clos-slots-ref .slots.
,i
) +slot-unbound
+)))
815 `(setf (clos-slots-ref .slots.
,i
)
816 (with-type-checked (,type
,safe-p
)
819 `(setf (clos-slots-ref .slots.
,i
)
820 (with-type-checked (,type
,safe-p
)
824 `(when (eq (clos-slots-ref .slots.
,i
)
826 (setf (clos-slots-ref .slots.
,i
)
827 (with-type-checked (,type
,safe-p
)
829 `(setf (clos-slots-ref .slots.
,i
)
830 (with-type-checked (,type
,safe-p
)
834 `(when (eq (clos-slots-ref .slots.
,i
)
836 (setf (clos-slots-ref .slots.
,i
)
837 (with-type-checked (,type
,safe-p
)
838 ',(constant-form-value value
))))
839 `(setf (clos-slots-ref .slots.
,i
)
840 (with-type-checked (,type
,safe-p
)
841 ',(constant-form-value value
)))))
843 `(setf (clos-slots-ref .slots.
,i
)
844 (with-type-checked (,type
,safe-p
)
845 ',(constant-form-value value
))))))))
846 ;; we are not allowed to modify QUOTEd locations, so we can't
847 ;; generate code like (setf (cdr ',location) arg). Instead,
848 ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
849 ;; be bound to the location.
850 (multiple-value-bind (names locations class-init-forms
)
851 (loop for
(location kind value type
) in class-inits
853 for name
= (location-var-name i
)
854 collect name into names
855 collect location into locations
856 collect
`(setf (cdr ,name
)
857 (with-type-checked (,type
,safe-p
)
859 (constant `',(constant-form-value value
))
860 ((param var
) `,value
)
861 (initfn `(funcall ,value
)))))
862 into class-init-forms
863 finally
(return (values names locations class-init-forms
)))
864 (multiple-value-bind (vars bindings
)
865 (loop for
(var . initfn
) in
(nreverse default-inits
)
866 collect var into vars
867 collect
`(,var
(funcall ,initfn
)) into bindings
868 finally
(return (values vars bindings
)))
869 (values locations names
871 (nreverse defaulting-initargs
)
872 `(,@(delete nil instance-init-forms
)
873 ,@class-init-forms
))))))))
875 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
876 ;;; telling, for each key in INITKEYS, which locations the initarg
877 ;;; initializes and the associated type with the location. CLASS is
878 ;;; the class of the instance being initialized.
879 (defun compute-initarg-locations (class initkeys
)
880 (loop with slots
= (class-slots class
)
881 for key in initkeys collect
882 (loop for slot in slots
883 if
(memq key
(slot-definition-initargs slot
))
884 collect
(cons (slot-definition-location slot
)
885 (slot-definition-type slot
))
888 collect slot into remaining-slots
890 (setq slots remaining-slots
)
891 (return (cons key locations
)))))
894 ;;; *******************************
895 ;;; External Entry Points ********
896 ;;; *******************************
898 (defun update-ctors (reason &key class name generic-function method
)
899 (labels ((reset (class &optional ri-cache-p
(ctorsp t
))
901 (dolist (ctor (plist-value class
'ctors
))
902 (install-initial-constructor ctor
)))
904 (setf (plist-value class
'ri-initargs
) ()))
905 (dolist (subclass (class-direct-subclasses class
))
906 (reset subclass ri-cache-p ctorsp
))))
908 ;; CLASS must have been specified.
909 (finalize-inheritance
911 ;; NAME must have been specified.
913 (loop for ctor in
*all-ctors
*
914 when
(eq (ctor-class-or-name ctor
) name
) do
915 (when (ctor-class ctor
)
916 (reset (ctor-class ctor
)))
918 ;; GENERIC-FUNCTION and METHOD must have been specified.
919 ((add-method remove-method
)
920 (flet ((class-of-1st-method-param (method)
921 (type-class (first (method-specializers method
)))))
922 (case (generic-function-name generic-function
)
923 ((make-instance allocate-instance
924 initialize-instance shared-initialize
)
925 (reset (class-of-1st-method-param method
) t t
))
926 ((reinitialize-instance)
927 (reset (class-of-1st-method-param method
) t nil
))
928 (t (when (or (eq (generic-function-name generic-function
)
929 'slot-boundp-using-class
)
930 (equal (generic-function-name generic-function
)
931 '(setf slot-value-using-class
)))
932 ;; this looks awfully expensive, but given that one
933 ;; can specialize on the SLOTD argument, nothing is
934 ;; safe. -- CSR, 2004-07-12
935 (reset (find-class 'standard-object
))))))))))
937 (defun precompile-ctors ()
938 (dolist (ctor *all-ctors
*)
939 (when (null (ctor-class ctor
))
940 (let ((class (find-class (ctor-class-or-name ctor
) nil
)))
941 (when (and class
(class-finalized-p class
))
942 (install-optimized-constructor ctor
))))))
944 (defun check-ri-initargs (instance initargs
)
945 (let* ((class (class-of instance
))
946 (keys (plist-keys initargs
))
947 (cached (assoc keys
(plist-value class
'ri-initargs
)
953 ;; FIXME: give CHECK-INITARGS-1 and friends a
954 ;; more mnemonic name and (possibly) a nicer,
955 ;; more orthogonal interface.
958 (list (list* 'reinitialize-instance instance initargs
)
959 (list* 'shared-initialize instance nil initargs
))
961 (setf (plist-value class
'ri-initargs
)
962 (acons keys invalid cached
))
965 (error 'initarg-error
:class class
:initargs invalid-keys
))))