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 (list* 'ctor class-name safe-code-p initargs))
157 ;;; Keep this a separate function for testing.
158 (defun ensure-ctor (function-name class-name initargs safe-code-p)
160 (if (fboundp function-name)
161 (the ctor (fdefinition function-name))
162 (make-ctor function-name class-name initargs safe-code-p))))
164 ;;; Keep this a separate function for testing.
165 (defun make-ctor (function-name class-name initargs safe-p)
166 (without-package-locks ; for (setf symbol-function)
167 (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p)))
168 (install-initial-constructor ctor :force-p t)
169 (push ctor *all-ctors*)
170 (setf (fdefinition function-name) ctor)
173 ;;; *****************
174 ;;; Inline CTOR cache
175 ;;; *****************
177 ;;; The cache starts out as a list of CTORs, sorted with the most recently
178 ;;; used CTORs near the head. If it expands too much, we switch to a vector
179 ;;; with a simple hashing scheme.
181 ;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
182 ;;; is in the list but not one of the 4 first ones, return a new list with the
183 ;;; found CTOR at the head. Thread-safe: the new list shares structure with
184 ;;; the old, but is not desctructively modified. Returning the old list for
185 ;;; hits close to the head reduces ping-ponging with multiple threads seeking
187 (defun find-ctor (key list)
188 (labels ((walk (tail from-head depth)
189 (declare (fixnum depth))
191 (let ((ctor (car tail)))
192 (if (eq (ctor-class-or-name ctor) key)
195 (nconc (list ctor) (nreverse from-head) (cdr tail)))
199 (cons ctor from-head)
200 (logand #xf (1+ depth)))))
204 (declaim (inline sxhash-symbol-or-class))
205 (defun sxhash-symbol-or-class (x)
206 (cond ((symbolp x) (sxhash x))
207 ((std-instance-p x) (std-instance-hash x))
208 ((fsc-instance-p x) (fsc-instance-hash x))
210 (bug "Something strange where symbol or class expected."))))
212 ;;; Max number of CTORs kept in an inline list cache. Once this is
213 ;;; exceeded we switch to a table.
214 (defconstant +ctor-list-max-size+ 12)
215 ;;; Max table size for CTOR cache. If the table fills up at this size
216 ;;; we keep the same size and drop 50% of the old entries.
217 (defconstant +ctor-table-max-size+ (expt 2 8))
218 ;;; Even if there is space in the cache, if we cannot fit a new entry
219 ;;; with max this number of collisions we expand the table (if possible)
221 (defconstant +ctor-table-max-probe-depth+ 5)
223 (defun make-ctor-table (size)
224 (declare (index size))
225 (let ((real-size (power-of-two-ceiling size)))
226 (if (< real-size +ctor-table-max-size+)
227 (values (make-array real-size :initial-element nil) nil)
228 (values (make-array +ctor-table-max-size+ :initial-element nil) t))))
230 (declaim (inline mix-ctor-hash))
231 (defun mix-ctor-hash (hash base)
232 (logand most-positive-fixnum (+ hash base 1)))
234 (defun put-ctor (ctor table)
235 (cond ((try-put-ctor ctor table)
238 (expand-ctor-table ctor table))))
240 ;;; Thread-safe: if two threads write to the same index in parallel, the other
241 ;;; result is just lost. This is not an issue as the CTORs are used as their
242 ;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
243 ;;; one is needed we just cache it again -- hopefully not getting stomped on
245 (defun try-put-ctor (ctor table)
246 (declare (simple-vector table) (optimize speed))
247 (let* ((class (ctor-class-or-name ctor))
248 (base (sxhash-symbol-or-class class))
250 (mask (1- (length table))))
251 (declare (fixnum base hash mask))
252 (loop repeat +ctor-table-max-probe-depth+
253 do (let* ((index (logand mask hash))
254 (old (aref table index)))
255 (cond ((and old (neq class (ctor-class-or-name old)))
256 (setf hash (mix-ctor-hash hash base)))
258 (setf (aref table index) ctor)
259 (return-from try-put-ctor t)))))
260 ;; Didn't fit, must expand
263 (defun get-ctor (class table)
264 (declare (simple-vector table) (optimize speed))
265 (let* ((base (sxhash-symbol-or-class class))
267 (mask (1- (length table))))
268 (declare (fixnum base hash mask))
269 (loop repeat +ctor-table-max-probe-depth+
270 do (let* ((index (logand mask hash))
271 (old (aref table index)))
272 (if (and old (eq class (ctor-class-or-name old)))
273 (return-from get-ctor old)
274 (setf hash (mix-ctor-hash hash base)))))
278 ;;; Thread safe: the old table is read, but if another thread mutates
279 ;;; it while we're reading we still get a sane result -- either the old
280 ;;; or the new entry. The new table is locally allocated, so that's ok
282 (defun expand-ctor-table (ctor old)
283 (declare (simple-vector old))
284 (let* ((old-size (length old))
285 (new-size (* 2 old-size))
286 (drop-random-entries nil))
289 (multiple-value-bind (new max-size-p) (make-ctor-table new-size)
290 (let ((action (if drop-random-entries
291 ;; Same logic as in method caches -- see comment
293 (randomly-punting-lambda (old-ctor)
294 (try-put-ctor old-ctor new))
296 (unless (try-put-ctor old-ctor new)
298 (setf drop-random-entries t)
299 (setf new-size (* 2 new-size)))
301 (aver (try-put-ctor ctor new))
302 (dotimes (i old-size)
303 (let ((old-ctor (aref old i)))
305 (funcall action old-ctor))))
306 (return-from expand-ctor-table (values ctor new)))))))
308 (defun ctor-list-to-table (list)
309 (let ((table (make-ctor-table (length list))))
311 (setf table (nth-value 1 (put-ctor ctor table))))
314 (defun ensure-cached-ctor (class-name store initargs safe-code-p)
315 (flet ((maybe-ctor-for-caching ()
316 (if (typep class-name '(or symbol class))
317 (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
318 (ensure-ctor name class-name initargs safe-code-p))
319 ;; Invalid first argument: let MAKE-INSTANCE worry about it.
320 (return-from ensure-cached-ctor
321 (values (lambda (&rest ctor-parameters)
323 (doplist (key value) initargs
324 (push key mi-initargs)
325 (push (if (constantp value)
327 (pop ctor-parameters))
329 (apply #'make-instance class-name (nreverse mi-initargs))))
332 (multiple-value-bind (ctor list) (find-ctor class-name store)
335 (let ((ctor (maybe-ctor-for-caching)))
336 (if (< (length list) +ctor-list-max-size+)
337 (values ctor (cons ctor list))
338 (values ctor (ctor-list-to-table list))))))
339 (let ((ctor (get-ctor class-name store)))
342 (put-ctor (maybe-ctor-for-caching) store))))))
344 ;;; ***********************************************
345 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
346 ;;; ***********************************************
348 (defvar *compiling-optimized-constructor* nil)
350 (define-compiler-macro make-instance (&whole form &rest args &environment env)
351 (declare (ignore args))
352 ;; Compiling an optimized constructor for a non-standard class means
353 ;; compiling a lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it
354 ;; -- need to make sure we don't recurse there.
355 (or (unless *compiling-optimized-constructor*
356 (make-instance->constructor-call form (safe-code-p env)))
359 (defun make-instance->constructor-call (form safe-code-p)
360 (destructuring-bind (class-arg &rest args) (cdr form)
362 ;; Return the name of parameter number I of a constructor
365 (format-symbol *pcl-package* ".P~D." i))
366 ;; Check if CLASS-ARG is a constant symbol. Give up if
369 (and class-arg (constant-class-arg-p class-arg)))
370 ;; Check if ARGS are suitable for an optimized constructor.
371 ;; Return NIL from the outer function if not.
373 (loop for (key . more) on args by #'cddr do
374 (when (or (null more)
375 (not (constant-symbol-p key))
376 (eq :allow-other-keys (constant-form-value key)))
377 (return-from make-instance->constructor-call nil)))))
379 ;; Collect a plist of initargs and constant values/parameter names
380 ;; in INITARGS. Collect non-constant initialization forms in
382 (multiple-value-bind (initargs value-forms)
383 (loop for (key value) on args by #'cddr and i from 0
384 collect (constant-form-value key) into initargs
386 collect value into initargs
388 collect (parameter-name i) into initargs
389 and collect value into value-forms
391 (return (values initargs value-forms)))
392 (if (constant-class-p)
393 (let* ((class-or-name (constant-form-value class-arg))
394 (function-name (make-ctor-function-name class-or-name initargs
396 ;; Prevent compiler warnings for calling the ctor.
397 (proclaim-as-fun-name function-name)
398 (note-name-defined function-name :function)
399 (when (eq (info :function :where-from function-name) :assumed)
400 (setf (info :function :where-from function-name) :defined)
401 (when (info :function :assumed-type function-name)
402 (setf (info :function :assumed-type function-name) nil)))
403 ;; Return code constructing a ctor at load time, which,
404 ;; when called, will set its funcallable instance
405 ;; function to an optimized constructor function.
407 (declare (disable-package-locks ,function-name))
408 (let ((.x. (load-time-value
409 (ensure-ctor ',function-name ',class-or-name ',initargs
411 (declare (ignore .x.))
412 ;; ??? check if this is worth it.
414 (ftype (or (function ,(make-list (length value-forms)
417 (function (&rest t) t))
419 (funcall (function ,function-name) ,@value-forms))))
420 (when (and class-arg (not (constantp class-arg)))
421 ;; Build an inline cache: a CONS, with the actual cache
423 `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
425 (let* ((.cache. (load-time-value (cons 'ctor-cache nil)))
426 (.store. (cdr .cache.))
427 (.class-arg. ,class-arg))
428 (multiple-value-bind (.fun. .new-store.)
429 (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p)
430 ;; Thread safe: if multiple threads hit this in
431 ;; parallel, the update from the other one is
432 ;; just lost -- no harm done, except for the need
433 ;; to redo the work next time.
434 (unless (eq .store. .new-store.)
435 (setf (cdr .cache.) .new-store.))
436 (funcall (truly-the function .fun.) ,@value-forms))))))))))
438 ;;; **************************************************
439 ;;; Load-Time Constructor Function Generation *******
440 ;;; **************************************************
442 ;;; The system-supplied primary INITIALIZE-INSTANCE and
443 ;;; SHARED-INITIALIZE methods. One cannot initialize these variables
444 ;;; to the right values here because said functions don't exist yet
445 ;;; when this file is first loaded.
446 (defvar *the-system-ii-method* nil)
447 (defvar *the-system-si-method* nil)
449 (defun install-optimized-constructor (ctor)
451 (let* ((class-or-name (ctor-class-or-name ctor))
452 (class (if (symbolp class-or-name)
453 (find-class class-or-name)
455 (unless (class-finalized-p class)
456 (finalize-inheritance class))
457 ;; We can have a class with an invalid layout here. Such a class
458 ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
459 ;; ...), because part of the deal is that those only happen from
460 ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
461 ;; class. An invalid layout of T needs to be flushed, however.
462 (when (eq (layout-invalid (class-wrapper class)) t)
463 (%force-cache-flushes class))
464 (setf (ctor-class ctor) class)
465 (pushnew ctor (plist-value class 'ctors) :test #'eq)
466 (multiple-value-bind (form locations names optimizedp)
467 (constructor-function-form ctor)
468 (setf (funcallable-instance-fun ctor)
470 (let ((*compiling-optimized-constructor* t))
471 (handler-bind ((compiler-note #'muffle-warning))
472 (compile nil `(lambda ,names ,form))))
474 (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
476 (defun constructor-function-form (ctor)
477 (let* ((class (ctor-class ctor))
478 (proto (class-prototype class))
479 (make-instance-methods
480 (compute-applicable-methods #'make-instance (list class)))
481 (allocate-instance-methods
482 (compute-applicable-methods #'allocate-instance (list class)))
483 ;; I stared at this in confusion for a while, thinking
484 ;; carefully about the possibility of the class prototype not
485 ;; being of sufficient discrimiating power, given the
486 ;; possibility of EQL-specialized methods on
487 ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given
488 ;; that this is a constructor optimization, the user doesn't
489 ;; yet have the instance to create a method with such an EQL
492 ;; There remains the (theoretical) possibility of someone
493 ;; coming along with code of the form
495 ;; (defmethod initialize-instance :before ((o foo) ...)
496 ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
498 ;; but probably we can afford not to worry about this too
499 ;; much for now. -- CSR, 2004-07-12
501 (compute-applicable-methods #'initialize-instance (list proto)))
503 (compute-applicable-methods #'shared-initialize (list proto t)))
505 (loop for slot in (class-slots class)
506 when (cdr (compute-applicable-methods
507 #'(setf slot-value-using-class)
508 (list nil class proto slot)))
511 (loop for slot in (class-slots class)
512 when (cdr (compute-applicable-methods
513 #'slot-boundp-using-class
514 (list class proto slot)))
516 ;; Cannot initialize these variables earlier because the generic
517 ;; functions don't exist when PCL is built.
518 (when (null *the-system-si-method*)
519 (setq *the-system-si-method*
520 (find-method #'shared-initialize
521 () (list *the-class-slot-object* *the-class-t*)))
522 (setq *the-system-ii-method*
523 (find-method #'initialize-instance
524 () (list *the-class-slot-object*))))
525 ;; Note that when there are user-defined applicable methods on
526 ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
527 ;; together with the system-defined ones in what
528 ;; COMPUTE-APPLICABLE-METHODS returns.
529 (let ((maybe-invalid-initargs
533 (ctor-default-initkeys
534 (ctor-initargs ctor) (class-default-initargs class))
535 (plist-keys (ctor-initargs ctor)))
536 (append ii-methods si-methods) nil nil))
537 (custom-make-instance
538 (not (null (cdr make-instance-methods)))))
539 (if (and (not (structure-class-p class))
540 (not (condition-class-p class))
541 (not custom-make-instance)
542 (null (cdr allocate-instance-methods))
544 (member (slot-definition-allocation x)
545 '(:instance :class)))
547 (not maybe-invalid-initargs)
548 (not (around-or-nonstandard-primary-method-p
549 ii-methods *the-system-ii-method*))
550 (not (around-or-nonstandard-primary-method-p
551 si-methods *the-system-si-method*)))
552 (optimizing-generator ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
553 (fallback-generator ctor ii-methods si-methods
554 (or maybe-invalid-initargs custom-make-instance))))))
556 (defun around-or-nonstandard-primary-method-p
557 (methods &optional standard-method)
558 (loop with primary-checked-p = nil
559 for method in methods
560 as qualifiers = (if (consp method)
561 (early-method-qualifiers method)
562 (safe-method-qualifiers method))
563 when (or (eq :around (car qualifiers))
564 (and (null qualifiers)
565 (not primary-checked-p)
566 (not (null standard-method))
567 (not (eq standard-method method))))
569 when (null qualifiers) do
570 (setq primary-checked-p t)))
572 (defun fallback-generator (ctor ii-methods si-methods use-make-instance)
573 (declare (ignore ii-methods si-methods))
574 (let ((class (ctor-class ctor))
575 (lambda-list (make-ctor-parameter-list ctor))
576 (initargs (quote-plist-keys (ctor-initargs ctor))))
577 (if use-make-instance
578 `(lambda ,lambda-list
579 (declare #.*optimize-speed*)
580 ;; The CTOR MAKE-INSTANCE optimization checks for
581 ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
582 ;; compilation of the constructor, hence avoiding the
583 ;; possibility of endless recursion.
584 (make-instance ,class ,@initargs))
585 (let ((defaults (class-default-initargs class)))
587 (setf initargs (ctor-default-initargs initargs defaults)))
588 `(lambda ,lambda-list
589 (declare #.*optimize-speed*)
590 (fast-make-instance ,class ,@initargs))))))
592 ;;; Not as good as the real optimizing generator, but faster than going
593 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
594 (defun fast-make-instance (class &rest initargs)
595 (declare #.*optimize-speed*)
596 (declare (dynamic-extent initargs))
597 (let ((.instance. (apply #'allocate-instance class initargs)))
598 (apply #'initialize-instance .instance. initargs)
601 (defun optimizing-generator
602 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
603 (multiple-value-bind (locations names body before-method-p)
604 (fake-initialization-emf ctor ii-methods si-methods
605 setf-svuc-slots sbuc-slots)
606 (let ((wrapper (class-wrapper (ctor-class ctor))))
608 `(lambda ,(make-ctor-parameter-list ctor)
609 (declare #.*optimize-speed*)
611 (when (layout-invalid ,wrapper)
612 (install-initial-constructor ,ctor)
613 (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
614 ,(wrap-in-allocate-forms ctor body before-method-p)))
619 ;;; Return a form wrapped around BODY that allocates an instance
620 ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
621 ;;; before-methods, in which case we initialize instance slots to
622 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables
623 ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot
624 ;;; vector around BODY.
625 (defun wrap-in-allocate-forms (ctor body before-method-p)
626 (let* ((class (ctor-class ctor))
627 (wrapper (class-wrapper class))
628 (allocation-function (raw-instance-allocator class))
629 (slots-fetcher (slots-fetcher class)))
630 (if (eq allocation-function 'allocate-standard-instance)
631 `(let ((.instance. (%make-standard-instance nil
632 (get-instance-hash-code)))
634 ,(layout-length wrapper)
635 ,@(when before-method-p
636 '(:initial-element +slot-unbound+)))))
637 (setf (std-instance-wrapper .instance.) ,wrapper)
638 (setf (std-instance-slots .instance.) .slots.)
641 `(let* ((.instance. (,allocation-function ,wrapper))
642 (.slots. (,slots-fetcher .instance.)))
643 (declare (ignorable .slots.))
647 ;;; Return a form for invoking METHOD with arguments from ARGS. As
648 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
649 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could
650 ;;; call fast method functions directly here, but benchmarks show that
651 ;;; there's no speed to gain, so lets avoid the hair here.
652 (defmacro invoke-method (method args)
653 `(funcall ,(method-function method) ,args ()))
655 ;;; Return a form that is sort of an effective method comprising all
656 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
657 ;;; normally have taken place when calling MAKE-INSTANCE.
658 (defun fake-initialization-emf
659 (ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
660 (multiple-value-bind (ii-around ii-before ii-primary ii-after)
661 (standard-sort-methods ii-methods)
662 (declare (ignore ii-primary))
663 (multiple-value-bind (si-around si-before si-primary si-after)
664 (standard-sort-methods si-methods)
665 (declare (ignore si-primary))
666 (aver (and (null ii-around) (null si-around)))
667 (let ((initargs (ctor-initargs ctor)))
669 (locations names bindings vars defaulting-initargs body)
670 (slot-init-forms ctor
671 (or ii-before si-before)
672 setf-svuc-slots sbuc-slots)
677 (declare (ignorable ,@vars))
678 (let (,@(when (or ii-before ii-after)
680 (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs))))
681 ,@(when (or si-before si-after)
683 (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs)))))
684 ,@(loop for method in ii-before
685 collect `(invoke-method ,method .ii-args.))
686 ,@(loop for method in si-before
687 collect `(invoke-method ,method .si-args.))
689 ,@(loop for method in si-after
690 collect `(invoke-method ,method .si-args.))
691 ,@(loop for method in ii-after
692 collect `(invoke-method ,method .ii-args.))))
693 (or ii-before si-before)))))))
695 ;;; Return four values from APPLICABLE-METHODS: around methods, before
696 ;;; methods, the applicable primary method, and applicable after
697 ;;; methods. Before and after methods are sorted in the order they
699 (defun standard-sort-methods (applicable-methods)
700 (loop for method in applicable-methods
701 as qualifiers = (if (consp method)
702 (early-method-qualifiers method)
703 (safe-method-qualifiers method))
705 collect method into primary
706 else if (eq :around (car qualifiers))
707 collect method into around
708 else if (eq :after (car qualifiers))
709 collect method into after
710 else if (eq :before (car qualifiers))
711 collect method into before
713 (return (values around before (first primary) (reverse after)))))
715 (defmacro with-type-checked ((type safe-p) &body body)
717 ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
718 ;; THE instead of e.g. CHECK-TYPE.
720 (declare (optimize (safety 3)))
721 (the ,type (progn ,@body)))
724 ;;; Return as multiple values bindings for default initialization
725 ;;; arguments, variable names, defaulting initargs and a body for
726 ;;; initializing instance and class slots of an object costructed by
727 ;;; CTOR. The variable .SLOTS. is assumed to bound to the instance's
728 ;;; slot vector. BEFORE-METHOD-P T means before-methods will be
729 ;;; called, which means that 1) other code will initialize instance
730 ;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and
731 ;;; that we have to check if these before-methods have set slots.
732 (defun slot-init-forms (ctor before-method-p setf-svuc-slots sbuc-slots)
733 (let* ((class (ctor-class ctor))
734 (initargs (ctor-initargs ctor))
735 (initkeys (plist-keys initargs))
736 (safe-p (ctor-safe-p ctor))
737 (wrapper (class-wrapper class))
739 (make-array (layout-length wrapper) :initial-element nil))
742 (defaulting-initargs ())
743 (default-initargs (class-default-initargs class))
745 (compute-initarg-locations
746 class (append initkeys (mapcar #'car default-initargs)))))
747 (labels ((initarg-locations (initarg)
748 (cdr (assoc initarg initarg-locations :test #'eq)))
749 (initializedp (location)
752 (assoc location class-inits :test #'eq))
754 (not (null (aref slot-vector location))))
755 (t (bug "Weird location in ~S" 'slot-init-forms))))
756 (class-init (location kind val type slotd)
757 (aver (consp location))
758 (unless (initializedp location)
759 (push (list location kind val type slotd) class-inits)))
760 (instance-init (location kind val type slotd)
761 (aver (integerp location))
762 (unless (initializedp location)
763 (setf (aref slot-vector location)
764 (list kind val type slotd))))
765 (default-init-var-name (i)
766 (format-symbol *pcl-package* ".D~D." i))
767 (location-var-name (i)
768 (format-symbol *pcl-package* ".L~D." i)))
769 ;; Loop over supplied initargs and values and record which
770 ;; instance and class slots they initialize.
771 (loop for (key value) on initargs by #'cddr
772 as kind = (if (constantp value) 'constant 'param)
773 as locations = (initarg-locations key)
774 do (loop for (location type slotd) in locations
775 do (if (consp location)
776 (class-init location kind value type slotd)
777 (instance-init location kind value type slotd))))
778 ;; Loop over default initargs of the class, recording
779 ;; initializations of slots that have not been initialized
780 ;; above. Default initargs which are not in the supplied
781 ;; initargs are treated as if they were appended to supplied
782 ;; initargs, that is, their values must be evaluated even
783 ;; if not actually used for initializing a slot.
784 (loop for (key initform initfn) in default-initargs and i from 0
785 unless (member key initkeys :test #'eq)
786 do (let* ((kind (if (constantp initform) 'constant 'var))
787 (init (if (eq kind 'var) initfn initform)))
790 (push (list 'quote key) defaulting-initargs)
791 (push initform defaulting-initargs))
793 (push (list 'quote key) defaulting-initargs)
794 (push (default-init-var-name i) defaulting-initargs)))
796 (let ((init-var (default-init-var-name i)))
798 (push (cons init-var initfn) default-inits)))
799 (loop for (location type slotd) in (initarg-locations key)
800 do (if (consp location)
801 (class-init location kind init type slotd)
802 (instance-init location kind init type slotd)))))
803 ;; Loop over all slots of the class, filling in the rest from
805 (loop for slotd in (class-slots class)
806 as location = (slot-definition-location slotd)
807 as type = (slot-definition-type slotd)
808 as allocation = (slot-definition-allocation slotd)
809 as initfn = (slot-definition-initfunction slotd)
810 as initform = (slot-definition-initform slotd) do
811 (unless (or (eq allocation :class)
813 (initializedp location))
814 (if (constantp initform)
815 (instance-init location 'initform initform type slotd)
816 (instance-init location
817 'initform/initfn initfn type slotd))))
818 ;; Generate the forms for initializing instance and class slots.
819 (let ((instance-init-forms
820 (loop for slot-entry across slot-vector and i from 0
821 as (kind value type slotd) = slot-entry
823 (flet ((setf-form (value-form)
824 (if (member slotd setf-svuc-slots :test #'eq)
825 `(setf (slot-value-using-class
826 ,class .instance. ,slotd)
828 `(setf (clos-slots-ref .slots. ,i)
829 (with-type-checked (,type ,safe-p)
832 (if (member slotd sbuc-slots :test #'eq)
833 `(slot-boundp-using-class
834 ,class .instance. ,slotd)
835 `(eq (clos-slots-ref .slots. ,i)
839 (unless before-method-p
840 `(setf (clos-slots-ref .slots. ,i)
845 (setf-form `(funcall ,value)))
848 `(when ,(not-boundp-form)
849 ,(setf-form `(funcall ,value)))
850 (setf-form `(funcall ,value))))
853 `(when ,(not-boundp-form)
854 ,(setf-form `',(constant-form-value value)))
855 (setf-form `',(constant-form-value value))))
857 (setf-form `',(constant-form-value value))))))))
858 ;; we are not allowed to modify QUOTEd locations, so we can't
859 ;; generate code like (setf (cdr ',location) arg). Instead,
860 ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
861 ;; be bound to the location.
862 (multiple-value-bind (names locations class-init-forms)
866 for (location kind value type slotd) in class-inits
869 (constant `',(constant-form-value value))
870 ((param var) `,value)
871 (initfn `(funcall ,value)))
872 when (member slotd setf-svuc-slots :test #'eq)
873 collect `(setf (slot-value-using-class
874 ,class .instance. ,slotd)
876 into class-init-forms
878 (let ((name (location-var-name (incf i))))
880 (push location locations)
882 (with-type-checked (,type ,safe-p)
884 into class-init-forms
885 finally (return (values (nreverse names)
888 (multiple-value-bind (vars bindings)
889 (loop for (var . initfn) in (nreverse default-inits)
890 collect var into vars
891 collect `(,var (funcall ,initfn)) into bindings
892 finally (return (values vars bindings)))
893 (values locations names
895 (nreverse defaulting-initargs)
896 `(,@(delete nil instance-init-forms)
897 ,@class-init-forms))))))))
899 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
900 ;;; telling, for each key in INITKEYS, which locations the initarg
901 ;;; initializes and the associated type with the location. CLASS is
902 ;;; the class of the instance being initialized.
903 (defun compute-initarg-locations (class initkeys)
904 (loop with slots = (class-slots class)
905 for key in initkeys collect
906 (loop for slot in slots
907 if (memq key (slot-definition-initargs slot))
908 collect (list (slot-definition-location slot)
909 (slot-definition-type slot)
913 collect slot into remaining-slots
915 (setq slots remaining-slots)
916 (return (cons key locations)))))
919 ;;; *******************************
920 ;;; External Entry Points ********
921 ;;; *******************************
923 (defun update-ctors (reason &key class name generic-function method)
924 (labels ((reset (class &optional initarg-caches-p (ctorsp t))
926 (dolist (ctor (plist-value class 'ctors))
927 (install-initial-constructor ctor)))
928 (when initarg-caches-p
929 (dolist (cache '(mi-initargs ri-initargs))
930 (setf (plist-value class cache) ())))
931 (dolist (subclass (class-direct-subclasses class))
932 (reset subclass initarg-caches-p ctorsp))))
934 ;; CLASS must have been specified.
935 (finalize-inheritance
937 ;; NAME must have been specified.
939 (loop for ctor in *all-ctors*
940 when (eq (ctor-class-or-name ctor) name) do
941 (when (ctor-class ctor)
942 (reset (ctor-class ctor)))
944 ;; GENERIC-FUNCTION and METHOD must have been specified.
945 ((add-method remove-method)
946 (flet ((class-of-1st-method-param (method)
947 (type-class (first (method-specializers method)))))
948 (case (generic-function-name generic-function)
949 ((make-instance allocate-instance)
950 ;; FIXME: I can't see a way of working out which classes a
951 ;; given metaclass specializer are applicable to short of
952 ;; iterating and testing with class-of. It would be good
953 ;; to not invalidate caches of system classes at this
954 ;; point (where it is not legal to define a method
955 ;; applicable to them on system functions). -- CSR,
957 (reset (find-class 'standard-object) t t))
958 ((initialize-instance shared-initialize)
959 (reset (class-of-1st-method-param method) t t))
960 ((reinitialize-instance)
961 (reset (class-of-1st-method-param method) t nil))
962 (t (when (or (eq (generic-function-name generic-function)
963 'slot-boundp-using-class)
964 (equal (generic-function-name generic-function)
965 '(setf slot-value-using-class)))
966 ;; this looks awfully expensive, but given that one
967 ;; can specialize on the SLOTD argument, nothing is
968 ;; safe. -- CSR, 2004-07-12
969 (reset (find-class 'standard-object))))))))))
971 (defun precompile-ctors ()
972 (dolist (ctor *all-ctors*)
973 (when (null (ctor-class ctor))
974 (let ((class (find-class (ctor-class-or-name ctor) nil)))
975 (when (and class (class-finalized-p class))
976 (install-optimized-constructor ctor))))))
978 (defun maybe-call-ctor (class initargs)
979 (flet ((frob-initargs (ctor)
980 (do ((ctail (ctor-initargs ctor))
983 ((or (null ctail) (null itail))
984 (values (nreverse args) (and (null ctail) (null itail))))
985 (unless (eq (pop ctail) (pop itail))
987 (let ((cval (pop ctail))
990 (unless (eql cval ival)
992 (push ival args))))))
993 (dolist (ctor (plist-value class 'ctors))
994 (when (eq (ctor-state ctor) 'optimized)
995 (multiple-value-bind (ctor-args matchp)
998 (return (apply ctor ctor-args))))))))
1000 ;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
1001 (defun check-mi-initargs (class initargs)
1002 (let* ((class-proto (class-prototype class))
1003 (keys (plist-keys initargs))
1004 (cache (plist-value class 'mi-initargs))
1005 (cached (assoc keys cache :test #'equal))
1012 (list (list* 'allocate-instance class initargs)
1013 (list* 'initialize-instance class-proto initargs)
1014 (list* 'shared-initialize class-proto t initargs))
1016 (setf (plist-value class 'mi-initargs)
1017 (acons keys invalid cache))
1020 ;; FIXME: should have an operation here, and maybe a set of
1022 (error 'initarg-error :class class :initargs invalid-keys))))
1024 (defun check-ri-initargs (instance initargs)
1025 (let* ((class (class-of instance))
1026 (keys (plist-keys initargs))
1027 (cache (plist-value class 'ri-initargs))
1028 (cached (assoc keys cache :test #'equal))
1033 ;; FIXME: give CHECK-INITARGS-1 and friends a
1034 ;; more mnemonic name and (possibly) a nicer,
1035 ;; more orthogonal interface.
1038 (list (list* 'reinitialize-instance instance initargs)
1039 (list* 'shared-initialize instance nil initargs))
1041 (setf (plist-value class 'ri-initargs)
1042 (acons keys invalid cache))
1045 (error 'initarg-error :class class :initargs invalid-keys))))
1047 ;;; end of ctor.lisp