Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / pcl / ctor.lisp
1 ;;;; This file contains the optimization machinery for make-instance.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
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.
11
12 ;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de>
13 ;;; All rights reserved.
14 ;;;
15 ;;; Redistribution and use in source and binary forms, with or without
16 ;;; modification, are permitted provided that the following conditions
17 ;;; are met:
18 ;;;
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
26 ;;;    permission.
27 ;;;
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
39 ;;; DAMAGE.
40
41 ;;; ***************
42 ;;; Overview  *****
43 ;;; ***************
44 ;;;
45 ;;; Compiler macro for MAKE-INSTANCE, and load-time generation of
46 ;;; optimized instance constructor functions.
47 ;;;
48 ;;; ********************
49 ;;; Entry Points  ******
50 ;;; ********************
51 ;;;
52 ;;; UPDATE-CTORS must be called when methods are added/removed,
53 ;;; classes are changed, etc., which affect instance creation.
54 ;;;
55 ;;; PRECOMPILE-CTORS can be called to precompile constructor functions
56 ;;; for classes whose definitions are known at the time the function
57 ;;; is called.
58
59 (in-package "SB-PCL")
60
61 ;;; ******************
62 ;;; Utilities  *******
63 ;;; ******************
64
65 (defun quote-plist-keys (plist)
66   (loop for (key . more) on plist by #'cddr
67         if (null more) do
68           (error "Not a property list: ~S" plist)
69         else
70           collect `(quote ,key)
71           and collect (car more)))
72
73 (defun plist-keys (plist &key test)
74   (loop for (key . more) on plist by #'cddr
75         if (null more) do
76           (error "Not a property list: ~S" plist)
77         else if (or (null test) (funcall test key))
78           collect key))
79
80 (defun plist-values (plist &key test)
81   (loop for (key . more) on plist by #'cddr
82         if (null more) do
83           (error "Not a property list: ~S" plist)
84         else if (or (null test) (funcall test (car more)))
85           collect (car more)))
86
87 (defun constant-class-arg-p (form)
88   (and (constantp form)
89        (let ((constant (constant-form-value form)))
90          (or (and (symbolp constant)
91                   (not (null (symbol-package constant))))
92              (classp form)))))
93
94 (defun constant-symbol-p (form)
95   (and (constantp form)
96        (let ((constant (constant-form-value form)))
97          (and (symbolp constant)
98               (not (null (symbol-package constant)))))))
99
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.)
105         collect key))
106
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
114         finally
115           (return (append supplied-initargs default-initargs))))
116 \f
117 ;;; *****************
118 ;;; CTORS   *********
119 ;;; *****************
120 ;;;
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.
125 ;;;
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)
134
135 ;;; List of all defined ctors.
136 (defvar *all-ctors* ())
137
138 (defun make-ctor-parameter-list (ctor)
139   (plist-values (ctor-initargs ctor) :test (complement #'constantp)))
140
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)
150               (apply ctor args)))
151     (setf (%funcallable-instance-info ctor 1)
152           (ctor-function-name ctor))))
153
154 (defun make-ctor-function-name (class-name initargs safe-code-p)
155   (labels ((arg-name (x)
156              (typecase x
157                ;; this list of types might look arbitrary but it is
158                ;; exactly the set of types descended into by EQUAL,
159                ;; which is the predicate used by globaldb to test for
160                ;; name equality.
161                (list (gensym "LIST-INITARG-"))
162                (string (gensym "STRING-INITARG-"))
163                (bit-vector (gensym "BIT-VECTOR-INITARG-"))
164                (pathname (gensym "PATHNAME-INITARG-"))
165                (t x)))
166            (munge (list)
167              (let ((*gensym-counter* 0))
168                (mapcar #'arg-name list))))
169     (list* 'ctor class-name safe-code-p (munge initargs))))
170
171 ;;; Keep this a separate function for testing.
172 (defun ensure-ctor (function-name class-name initargs safe-code-p)
173   (with-world-lock ()
174     (if (fboundp function-name)
175         (the ctor (fdefinition function-name))
176         (make-ctor function-name class-name initargs safe-code-p))))
177
178 ;;; Keep this a separate function for testing.
179 (defun make-ctor (function-name class-name initargs safe-p)
180   (without-package-locks ; for (setf symbol-function)
181     (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p)))
182       (install-initial-constructor ctor :force-p t)
183       (push ctor *all-ctors*)
184       (setf (fdefinition function-name) ctor)
185       ctor)))
186 \f
187 ;;; *****************
188 ;;; Inline CTOR cache
189 ;;; *****************
190 ;;;
191 ;;; The cache starts out as a list of CTORs, sorted with the most recently
192 ;;; used CTORs near the head. If it expands too much, we switch to a vector
193 ;;; with a simple hashing scheme.
194
195 ;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
196 ;;; is in the list but not one of the 4 first ones, return a new list with the
197 ;;; found CTOR at the head. Thread-safe: the new list shares structure with
198 ;;; the old, but is not desctructively modified. Returning the old list for
199 ;;; hits close to the head reduces ping-ponging with multiple threads seeking
200 ;;; the same list.
201 (defun find-ctor (key list)
202   (labels ((walk (tail from-head depth)
203              (declare (fixnum depth))
204              (if tail
205                  (let ((ctor (car tail)))
206                    (if (eq (ctor-class-or-name ctor) key)
207                        (if (> depth 3)
208                            (values ctor
209                                    (nconc (list ctor) (nreverse from-head) (cdr tail)))
210                            (values ctor
211                                    list))
212                        (walk (cdr tail)
213                              (cons ctor from-head)
214                              (logand #xf (1+ depth)))))
215                  (values nil list))))
216     (walk list nil 0)))
217
218 (declaim (inline sxhash-symbol-or-class))
219 (defun sxhash-symbol-or-class (x)
220   (cond ((symbolp x) (sxhash x))
221         ((std-instance-p x) (std-instance-hash x))
222         ((fsc-instance-p x) (fsc-instance-hash x))
223         (t
224          (bug "Something strange where symbol or class expected."))))
225
226 ;;; Max number of CTORs kept in an inline list cache. Once this is
227 ;;; exceeded we switch to a table.
228 (defconstant +ctor-list-max-size+ 12)
229 ;;; Max table size for CTOR cache. If the table fills up at this size
230 ;;; we keep the same size and drop 50% of the old entries.
231 (defconstant +ctor-table-max-size+ (expt 2 8))
232 ;;; Even if there is space in the cache, if we cannot fit a new entry
233 ;;; with max this number of collisions we expand the table (if possible)
234 ;;; and rehash.
235 (defconstant +ctor-table-max-probe-depth+ 5)
236
237 (defun make-ctor-table (size)
238   (declare (index size))
239   (let ((real-size (power-of-two-ceiling size)))
240     (if (< real-size +ctor-table-max-size+)
241         (values (make-array real-size :initial-element nil) nil)
242         (values (make-array +ctor-table-max-size+ :initial-element nil) t))))
243
244 (declaim (inline mix-ctor-hash))
245 (defun mix-ctor-hash (hash base)
246   (logand most-positive-fixnum (+ hash base 1)))
247
248 (defun put-ctor (ctor table)
249   (cond ((try-put-ctor ctor table)
250          (values ctor table))
251         (t
252          (expand-ctor-table ctor table))))
253
254 ;;; Thread-safe: if two threads write to the same index in parallel, the other
255 ;;; result is just lost. This is not an issue as the CTORs are used as their
256 ;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
257 ;;; one is needed we just cache it again -- hopefully not getting stomped on
258 ;;; that time.
259 (defun try-put-ctor (ctor table)
260   (declare (simple-vector table) (optimize speed))
261   (let* ((class (ctor-class-or-name ctor))
262          (base (sxhash-symbol-or-class class))
263          (hash base)
264          (mask (1- (length table))))
265     (declare (fixnum base hash mask))
266     (loop repeat +ctor-table-max-probe-depth+
267           do (let* ((index (logand mask hash))
268                     (old (aref table index)))
269                (cond ((and old (neq class (ctor-class-or-name old)))
270                       (setf hash (mix-ctor-hash hash base)))
271                      (t
272                       (setf (aref table index) ctor)
273                       (return-from try-put-ctor t)))))
274     ;; Didn't fit, must expand
275     nil))
276
277 (defun get-ctor (class table)
278   (declare (simple-vector table) (optimize speed))
279   (let* ((base (sxhash-symbol-or-class class))
280          (hash base)
281          (mask (1- (length table))))
282     (declare (fixnum base hash mask))
283     (loop repeat +ctor-table-max-probe-depth+
284           do (let* ((index (logand mask hash))
285                     (old (aref table index)))
286                (if (and old (eq class (ctor-class-or-name old)))
287                    (return-from get-ctor old)
288                    (setf hash (mix-ctor-hash hash base)))))
289     ;; Nothing.
290     nil))
291
292 ;;; Thread safe: the old table is read, but if another thread mutates
293 ;;; it while we're reading we still get a sane result -- either the old
294 ;;; or the new entry. The new table is locally allocated, so that's ok
295 ;;; too.
296 (defun expand-ctor-table (ctor old)
297   (declare (simple-vector old))
298   (let* ((old-size (length old))
299          (new-size (* 2 old-size))
300          (drop-random-entries nil))
301     (tagbody
302      :again
303        (multiple-value-bind (new max-size-p) (make-ctor-table new-size)
304          (let ((action (if drop-random-entries
305                            ;; Same logic as in method caches -- see comment
306                            ;; there.
307                            (randomly-punting-lambda (old-ctor)
308                              (try-put-ctor old-ctor new))
309                            (lambda (old-ctor)
310                              (unless (try-put-ctor old-ctor new)
311                                (if max-size-p
312                                    (setf drop-random-entries t)
313                                    (setf new-size (* 2 new-size)))
314                                (go :again))))))
315            (aver (try-put-ctor ctor new))
316            (dotimes (i old-size)
317              (let ((old-ctor (aref old i)))
318                (when old-ctor
319                  (funcall action old-ctor))))
320            (return-from expand-ctor-table (values ctor new)))))))
321
322 (defun ctor-list-to-table (list)
323   (let ((table (make-ctor-table (length list))))
324     (dolist (ctor list)
325       (setf table (nth-value 1 (put-ctor ctor table))))
326     table))
327
328 (defun ensure-cached-ctor (class-name store initargs safe-code-p)
329   (flet ((maybe-ctor-for-caching ()
330            (if (typep class-name '(or symbol class))
331                (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
332                  (ensure-ctor name class-name initargs safe-code-p))
333                ;; Invalid first argument: let MAKE-INSTANCE worry about it.
334                (return-from ensure-cached-ctor
335                  (values (lambda (&rest ctor-parameters)
336                            (let (mi-initargs)
337                              (doplist (key value) initargs
338                                (push key mi-initargs)
339                                (push (if (constantp value)
340                                          value
341                                          (pop ctor-parameters))
342                                      mi-initargs))
343                              (apply #'make-instance class-name (nreverse mi-initargs))))
344                          store)))))
345     (if (listp store)
346         (multiple-value-bind (ctor list) (find-ctor class-name store)
347           (if ctor
348               (values ctor list)
349               (let ((ctor (maybe-ctor-for-caching)))
350                 (if (< (length list) +ctor-list-max-size+)
351                     (values ctor (cons ctor list))
352                     (values ctor (ctor-list-to-table list))))))
353        (let ((ctor (get-ctor class-name store)))
354          (if ctor
355              (values ctor store)
356              (put-ctor (maybe-ctor-for-caching) store))))))
357 \f
358 ;;; ***********************************************
359 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
360 ;;; ***********************************************
361
362 (defvar *compiling-optimized-constructor* nil)
363
364 (define-compiler-macro make-instance (&whole form &rest args &environment env)
365   (declare (ignore args))
366   ;; Compiling an optimized constructor for a non-standard class means
367   ;; compiling a lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it
368   ;; -- need to make sure we don't recurse there.
369   (or (unless *compiling-optimized-constructor*
370         (make-instance->constructor-call form (safe-code-p env)))
371       form))
372
373 (defun make-instance->constructor-call (form safe-code-p)
374   (destructuring-bind (class-arg &rest args) (cdr form)
375     (flet (;;
376            ;; Return the name of parameter number I of a constructor
377            ;; function.
378            (parameter-name (i)
379              (format-symbol *pcl-package* ".P~D." i))
380            ;; Check if CLASS-ARG is a constant symbol.  Give up if
381            ;; not.
382            (constant-class-p ()
383              (and class-arg (constant-class-arg-p class-arg)))
384            ;; Check if ARGS are suitable for an optimized constructor.
385            ;; Return NIL from the outer function if not.
386            (check-args ()
387              (loop for (key . more) on args by #'cddr do
388                       (when (or (null more)
389                                 (not (constant-symbol-p key))
390                                 (eq :allow-other-keys (constant-form-value key)))
391                         (return-from make-instance->constructor-call nil)))))
392       (check-args)
393       ;; Collect a plist of initargs and constant values/parameter names
394       ;; in INITARGS.  Collect non-constant initialization forms in
395       ;; VALUE-FORMS.
396       (multiple-value-bind (initargs value-forms)
397           (loop for (key value) on args by #'cddr and i from 0
398                 collect (constant-form-value key) into initargs
399                 if (constantp value)
400                 collect value into initargs
401                 else
402                 collect (parameter-name i) into initargs
403                 and collect value into value-forms
404                 finally
405                 (return (values initargs value-forms)))
406         (if (constant-class-p)
407             (let* ((class-or-name (constant-form-value class-arg))
408                    (function-name (make-ctor-function-name class-or-name initargs
409                                                            safe-code-p)))
410               ;; Prevent compiler warnings for calling the ctor.
411               (proclaim-as-fun-name function-name)
412               (note-name-defined function-name :function)
413               (when (eq (info :function :where-from function-name) :assumed)
414                 (setf (info :function :where-from function-name) :defined)
415                 (when (info :function :assumed-type function-name)
416                   (setf (info :function :assumed-type function-name) nil)))
417               ;; Return code constructing a ctor at load time, which,
418               ;; when called, will set its funcallable instance
419               ;; function to an optimized constructor function.
420               `(locally
421                    (declare (disable-package-locks ,function-name))
422                  (let ((.x. (load-time-value
423                              (ensure-ctor ',function-name ',class-or-name ',initargs
424                                           ',safe-code-p))))
425                    (declare (ignore .x.))
426                    ;; ??? check if this is worth it.
427                    (declare
428                     (ftype (or (function ,(make-list (length value-forms)
429                                                      :initial-element t)
430                                          t)
431                                (function (&rest t) t))
432                            ,function-name))
433                    (funcall (function ,function-name) ,@value-forms))))
434             (when (and class-arg (not (constantp class-arg)))
435               ;; Build an inline cache: a CONS, with the actual cache
436               ;; in the CDR.
437               `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
438                                                         make-instance))
439                  (let* ((.cache. (load-time-value (cons 'ctor-cache nil)))
440                         (.store. (cdr .cache.))
441                         (.class-arg. ,class-arg))
442                    (multiple-value-bind (.fun. .new-store.)
443                        (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p)
444                      ;; Thread safe: if multiple threads hit this in
445                      ;; parallel, the update from the other one is
446                      ;; just lost -- no harm done, except for the need
447                      ;; to redo the work next time.
448                      (unless (eq .store. .new-store.)
449                        (setf (cdr .cache.) .new-store.))
450                      (funcall (truly-the function .fun.) ,@value-forms))))))))))
451 \f
452 ;;; **************************************************
453 ;;; Load-Time Constructor Function Generation  *******
454 ;;; **************************************************
455
456 ;;; The system-supplied primary INITIALIZE-INSTANCE and
457 ;;; SHARED-INITIALIZE methods.  One cannot initialize these variables
458 ;;; to the right values here because said functions don't exist yet
459 ;;; when this file is first loaded.
460 (defvar *the-system-ii-method* nil)
461 (defvar *the-system-si-method* nil)
462
463 (defun install-optimized-constructor (ctor)
464   (with-world-lock ()
465     (let* ((class-or-name (ctor-class-or-name ctor))
466            (class (if (symbolp class-or-name)
467                       (find-class class-or-name)
468                       class-or-name)))
469       (unless (class-finalized-p class)
470         (finalize-inheritance class))
471       ;; We can have a class with an invalid layout here.  Such a class
472       ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
473       ;; ...), because part of the deal is that those only happen from
474       ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
475       ;; class.  An invalid layout of T needs to be flushed, however.
476       (when (eq (layout-invalid (class-wrapper class)) t)
477         (%force-cache-flushes class))
478       (setf (ctor-class ctor) class)
479       (pushnew ctor (plist-value class 'ctors) :test #'eq)
480       (multiple-value-bind (form locations names optimizedp)
481           (constructor-function-form ctor)
482         (setf (funcallable-instance-fun ctor)
483               (apply
484                (let ((*compiling-optimized-constructor* t))
485                  (handler-bind ((compiler-note #'muffle-warning))
486                    (compile nil `(lambda ,names ,form))))
487                locations)
488               (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
489
490 (defun constructor-function-form (ctor)
491   (let* ((class (ctor-class ctor))
492          (proto (class-prototype class))
493          (make-instance-methods
494           (compute-applicable-methods #'make-instance (list class)))
495          (allocate-instance-methods
496           (compute-applicable-methods #'allocate-instance (list class)))
497          ;; I stared at this in confusion for a while, thinking
498          ;; carefully about the possibility of the class prototype not
499          ;; being of sufficient discrimiating power, given the
500          ;; possibility of EQL-specialized methods on
501          ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE.  However, given
502          ;; that this is a constructor optimization, the user doesn't
503          ;; yet have the instance to create a method with such an EQL
504          ;; specializer.
505          ;;
506          ;; There remains the (theoretical) possibility of someone
507          ;; coming along with code of the form
508          ;;
509          ;; (defmethod initialize-instance :before ((o foo) ...)
510          ;;   (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
511          ;;
512          ;; but probably we can afford not to worry about this too
513          ;; much for now.  -- CSR, 2004-07-12
514          (ii-methods
515           (compute-applicable-methods #'initialize-instance (list proto)))
516          (si-methods
517           (compute-applicable-methods #'shared-initialize (list proto t)))
518          (setf-svuc-slots
519           (loop for slot in (class-slots class)
520                 when (cdr (compute-applicable-methods
521                            #'(setf slot-value-using-class)
522                            (list nil class proto slot)))
523                 collect slot))
524          (sbuc-slots
525           (loop for slot in (class-slots class)
526                 when (cdr (compute-applicable-methods
527                            #'slot-boundp-using-class
528                            (list class proto slot)))
529                 collect slot)))
530     ;; Cannot initialize these variables earlier because the generic
531     ;; functions don't exist when PCL is built.
532     (when (null *the-system-si-method*)
533       (setq *the-system-si-method*
534             (find-method #'shared-initialize
535                          () (list *the-class-slot-object* *the-class-t*)))
536       (setq *the-system-ii-method*
537             (find-method #'initialize-instance
538                          () (list *the-class-slot-object*))))
539     ;; Note that when there are user-defined applicable methods on
540     ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
541     ;; together with the system-defined ones in what
542     ;; COMPUTE-APPLICABLE-METHODS returns.
543     (let ((maybe-invalid-initargs
544            (check-initargs-1
545             class
546             (append
547              (ctor-default-initkeys
548               (ctor-initargs ctor) (class-default-initargs class))
549              (plist-keys (ctor-initargs ctor)))
550             (append ii-methods si-methods) nil nil))
551           (custom-make-instance
552            (not (null (cdr make-instance-methods)))))
553       (if (and (not (structure-class-p class))
554                (not (condition-class-p class))
555                (not custom-make-instance)
556                (null (cdr allocate-instance-methods))
557                (every (lambda (x)
558                         (member (slot-definition-allocation x)
559                                 '(:instance :class)))
560                       (class-slots class))
561                (not maybe-invalid-initargs)
562                (not (hairy-around-or-nonstandard-primary-method-p
563                      ii-methods *the-system-ii-method*))
564                (not (around-or-nonstandard-primary-method-p
565                      si-methods *the-system-si-method*)))
566           (optimizing-generator ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
567           (fallback-generator ctor ii-methods si-methods
568                               (or maybe-invalid-initargs custom-make-instance))))))
569
570 (defun around-or-nonstandard-primary-method-p
571     (methods &optional standard-method)
572   (loop with primary-checked-p = nil
573         for method in methods
574         as qualifiers = (if (consp method)
575                             (early-method-qualifiers method)
576                             (safe-method-qualifiers method))
577         when (or (eq :around (car qualifiers))
578                  (and (null qualifiers)
579                       (not primary-checked-p)
580                       (not (null standard-method))
581                       (not (eq standard-method method))))
582           return t
583         when (null qualifiers) do
584           (setq primary-checked-p t)))
585
586 (defun hairy-around-or-nonstandard-primary-method-p
587     (methods &optional standard-method)
588   (loop with primary-checked-p = nil
589         for method in methods
590         as qualifiers = (if (consp method)
591                             (early-method-qualifiers method)
592                             (safe-method-qualifiers method))
593         when (or (and (eq :around (car qualifiers))
594                       (not (simple-next-method-call-p method)))
595               (and (null qualifiers)
596                       (not primary-checked-p)
597                       (not (null standard-method))
598                       (not (eq standard-method method))))
599           return t
600         when (null qualifiers) do
601           (setq primary-checked-p t)))
602
603 (defun fallback-generator (ctor ii-methods si-methods use-make-instance)
604   (declare (ignore ii-methods si-methods))
605   (let ((class (ctor-class ctor))
606         (lambda-list (make-ctor-parameter-list ctor))
607         (initargs (quote-plist-keys (ctor-initargs ctor))))
608     (if use-make-instance
609         `(lambda ,lambda-list
610            (declare #.*optimize-speed*)
611            ;; The CTOR MAKE-INSTANCE optimization checks for
612            ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
613            ;; compilation of the constructor, hence avoiding the
614            ;; possibility of endless recursion.
615            (make-instance ,class ,@initargs))
616         (let ((defaults (class-default-initargs class)))
617           (when defaults
618             (setf initargs (ctor-default-initargs initargs defaults)))
619           `(lambda ,lambda-list
620              (declare #.*optimize-speed*)
621              (fast-make-instance ,class ,@initargs))))))
622
623 ;;; Not as good as the real optimizing generator, but faster than going
624 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
625 (defun fast-make-instance (class &rest initargs)
626   (declare #.*optimize-speed*)
627   (declare (dynamic-extent initargs))
628   (let ((.instance. (apply #'allocate-instance class initargs)))
629     (apply #'initialize-instance .instance. initargs)
630     .instance.))
631
632 (defun optimizing-generator
633     (ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
634   (multiple-value-bind (locations names body early-unbound-markers-p)
635       (fake-initialization-emf ctor ii-methods si-methods
636                                setf-svuc-slots sbuc-slots)
637     (let ((wrapper (class-wrapper (ctor-class ctor))))
638       (values
639        `(lambda ,(make-ctor-parameter-list ctor)
640          (declare #.*optimize-speed*)
641          (block nil
642            (when (layout-invalid ,wrapper)
643              (install-initial-constructor ,ctor)
644              (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
645            ,(wrap-in-allocate-forms ctor body early-unbound-markers-p)))
646        locations
647        names
648        t))))
649
650 ;;; Return a form wrapped around BODY that allocates an instance constructed
651 ;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we
652 ;;; have explicitly initialized them, requiring all slots to start as
653 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables .INSTANCE. to
654 ;;; the instance, and .SLOTS. to the instance's slot vector around BODY.
655 (defun wrap-in-allocate-forms (ctor body early-unbound-markers-p)
656   (let* ((class (ctor-class ctor))
657          (wrapper (class-wrapper class))
658          (allocation-function (raw-instance-allocator class))
659          (slots-fetcher (slots-fetcher class)))
660     (if (eq allocation-function 'allocate-standard-instance)
661         `(let ((.instance. (%make-standard-instance nil
662                                                     (get-instance-hash-code)))
663                (.slots. (make-array
664                          ,(layout-length wrapper)
665                          ,@(when early-unbound-markers-p
666                                  '(:initial-element +slot-unbound+)))))
667            (setf (std-instance-wrapper .instance.) ,wrapper)
668            (setf (std-instance-slots .instance.) .slots.)
669            ,body
670            .instance.)
671         `(let* ((.instance. (,allocation-function ,wrapper))
672                 (.slots. (,slots-fetcher .instance.)))
673            (declare (ignorable .slots.))
674            ,body
675            .instance.))))
676
677 ;;; Return a form for invoking METHOD with arguments from ARGS.  As
678 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
679 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...).  We could
680 ;;; call fast method functions directly here, but benchmarks show that
681 ;;; there's no speed to gain, so lets avoid the hair here.
682 (defmacro invoke-method (method args &optional next-methods)
683   `(funcall ,(the function (method-function method)) ,args ,next-methods))
684
685 ;;; Return a form that is sort of an effective method comprising all
686 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
687 ;;; normally have taken place when calling MAKE-INSTANCE.
688 (defun fake-initialization-emf
689     (ctor ii-methods si-methods setf-svuc-slots sbuc-slots)
690   (multiple-value-bind (ii-around ii-before ii-primary ii-after)
691       (standard-sort-methods ii-methods)
692     (declare (ignore ii-primary))
693     (multiple-value-bind (si-around si-before si-primary si-after)
694         (standard-sort-methods si-methods)
695       (declare (ignore si-primary))
696       (aver (null si-around))
697       (let ((initargs (ctor-initargs ctor))
698             ;; :BEFORE and :AROUND initialization methods, and SETF SVUC and
699             ;; SBUC methods can cause slots to be accessed before the we have
700             ;; touched them here, which requires the instance-vector to be
701             ;; initialized with +SLOT-UNBOUND+ to start with.
702             (early-unbound-markers-p (or ii-before si-before ii-around
703                                          setf-svuc-slots sbuc-slots)))
704         (multiple-value-bind
705               (locations names bindings vars defaulting-initargs body)
706             (slot-init-forms ctor
707                              early-unbound-markers-p
708                              setf-svuc-slots sbuc-slots)
709         (values
710          locations
711          names
712          `(let ,bindings
713            (declare (ignorable ,@vars))
714            (flet ((initialize-it (.ii-args. .next-methods.)
715                     ;; This has all the :BEFORE and :AFTER methods,
716                     ;; and BODY does what primary SI method would do.
717                     (declare (ignore .next-methods.))
718                     (let* ((.instance. (car .ii-args.))
719                            ,@(when (or si-before si-after)
720                                   `((.si-args.
721                                      (list* .instance. t (cdr .ii-args.))))))
722                       ,@(loop for method in ii-before
723                               collect `(invoke-method ,method .ii-args.))
724                       ,@(loop for method in si-before
725                               collect `(invoke-method ,method .si-args.))
726                       ,@body
727                       ,@(loop for method in si-after
728                               collect `(invoke-method ,method .si-args.))
729                       ,@(loop for method in ii-after
730                               collect `(invoke-method ,method .ii-args.))
731                       .instance.)))
732              (declare (dynamic-extent #'initialize-it))
733              (let ((.ii-args.
734                     ,@(if (or ii-before ii-after ii-around si-before si-after)
735                           `((list .instance. ,@(quote-plist-keys initargs)
736                                   ,@defaulting-initargs))
737                           `((list .instance.)))))
738                ,(if ii-around
739                     ;; If there are :AROUND methods, call them first -- they get
740                     ;; the normal chaining, with #'INITIALIZE-IT standing in for
741                     ;; the rest.
742                     `(let ((.next-methods.
743                             (list ,@(cdr ii-around) #'initialize-it)))
744                        (declare (dynamic-extent .next-methods.))
745                        (invoke-method ,(car ii-around) .ii-args. .next-methods.))
746                     ;; The simple case.
747                     `(initialize-it .ii-args. nil)))))
748          early-unbound-markers-p))))))
749
750 ;;; Return four values from APPLICABLE-METHODS: around methods, before
751 ;;; methods, the applicable primary method, and applicable after
752 ;;; methods.  Before and after methods are sorted in the order they
753 ;;; must be called.
754 (defun standard-sort-methods (applicable-methods)
755   (loop for method in applicable-methods
756         as qualifiers = (if (consp method)
757                             (early-method-qualifiers method)
758                             (safe-method-qualifiers method))
759         if (null qualifiers)
760           collect method into primary
761         else if (eq :around (car qualifiers))
762           collect method into around
763         else if (eq :after (car qualifiers))
764           collect method into after
765         else if (eq :before (car qualifiers))
766           collect method into before
767         finally
768           (return (values around before (first primary) (reverse after)))))
769
770 (defmacro with-type-checked ((type safe-p) &body body)
771   (if safe-p
772       ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
773       ;; THE instead of e.g. CHECK-TYPE.
774       `(locally
775            (declare (optimize (safety 3)))
776          (the ,type (progn ,@body)))
777       `(progn ,@body)))
778
779 ;;; Return as multiple values bindings for default initialization arguments,
780 ;;; variable names, defaulting initargs and a body for initializing instance
781 ;;; and class slots of an object costructed by CTOR. The variable .SLOTS. is
782 ;;; assumed to bound to the instance's slot vector. EARLY-UNBOUND-MARKERS-P
783 ;;; means other code will initialize instance slots to +SLOT-UNBOUND+, and we
784 ;;; have to check if something has already set slots before we initialize
785 ;;; them.
786 (defun slot-init-forms (ctor early-unbound-markers-p setf-svuc-slots sbuc-slots)
787   (let* ((class (ctor-class ctor))
788          (initargs (ctor-initargs ctor))
789          (initkeys (plist-keys initargs))
790          (safe-p (ctor-safe-p ctor))
791          (wrapper (class-wrapper class))
792          (slot-vector
793           (make-array (layout-length wrapper) :initial-element nil))
794          (class-inits ())
795          (default-inits ())
796          (defaulting-initargs ())
797          (default-initargs (class-default-initargs class))
798          (initarg-locations
799           (compute-initarg-locations
800            class (append initkeys (mapcar #'car default-initargs)))))
801     (labels ((initarg-locations (initarg)
802                (cdr (assoc initarg initarg-locations :test #'eq)))
803              (initializedp (location)
804                (cond
805                  ((consp location)
806                   (assoc location class-inits :test #'eq))
807                  ((integerp location)
808                   (not (null (aref slot-vector location))))
809                  (t (bug "Weird location in ~S" 'slot-init-forms))))
810              (class-init (location kind val type slotd)
811                (aver (consp location))
812                (unless (initializedp location)
813                  (push (list location kind val type slotd) class-inits)))
814              (instance-init (location kind val type slotd)
815                (aver (integerp location))
816                (unless (initializedp location)
817                  (setf (aref slot-vector location)
818                        (list kind val type slotd))))
819              (default-init-var-name (i)
820                (format-symbol *pcl-package* ".D~D." i))
821              (location-var-name (i)
822                (format-symbol *pcl-package* ".L~D." i)))
823       ;; Loop over supplied initargs and values and record which
824       ;; instance and class slots they initialize.
825       (loop for (key value) on initargs by #'cddr
826             as kind = (if (constantp value) 'constant 'param)
827             as locations = (initarg-locations key)
828             do (loop for (location type slotd) in locations
829                      do (if (consp location)
830                             (class-init location kind value type slotd)
831                             (instance-init location kind value type slotd))))
832       ;; Loop over default initargs of the class, recording
833       ;; initializations of slots that have not been initialized
834       ;; above.  Default initargs which are not in the supplied
835       ;; initargs are treated as if they were appended to supplied
836       ;; initargs, that is, their values must be evaluated even
837       ;; if not actually used for initializing a slot.
838       (loop for (key initform initfn) in default-initargs and i from 0
839             unless (member key initkeys :test #'eq)
840             do (let* ((kind (if (constantp initform) 'constant 'var))
841                       (init (if (eq kind 'var) initfn initform)))
842                  (ecase kind
843                    (constant
844                     (push (list 'quote key) defaulting-initargs)
845                     (push initform defaulting-initargs))
846                    (var
847                     (push (list 'quote key) defaulting-initargs)
848                     (push (default-init-var-name i) defaulting-initargs)))
849               (when (eq kind 'var)
850                 (let ((init-var (default-init-var-name i)))
851                   (setq init init-var)
852                   (push (cons init-var initfn) default-inits)))
853               (loop for (location type slotd) in (initarg-locations key)
854                     do (if (consp location)
855                            (class-init location kind init type slotd)
856                            (instance-init location kind init type slotd)))))
857       ;; Loop over all slots of the class, filling in the rest from
858       ;; slot initforms.
859       (loop for slotd in (class-slots class)
860             as location = (slot-definition-location slotd)
861             as type = (slot-definition-type slotd)
862             as allocation = (slot-definition-allocation slotd)
863             as initfn = (slot-definition-initfunction slotd)
864             as initform = (slot-definition-initform slotd) do
865               (unless (or (eq allocation :class)
866                           (null initfn)
867                           (initializedp location))
868                 (if (constantp initform)
869                     (instance-init location 'initform initform type slotd)
870                     (instance-init location
871                                    'initform/initfn initfn type slotd))))
872       ;; Generate the forms for initializing instance and class slots.
873       (let ((instance-init-forms
874              (loop for slot-entry across slot-vector and i from 0
875                    as (kind value type slotd) = slot-entry
876                    collect
877                       (flet ((setf-form (value-form)
878                                (if (member slotd setf-svuc-slots :test #'eq)
879                                    `(setf (slot-value-using-class
880                                            ,class .instance. ,slotd)
881                                           ,value-form)
882                                    `(setf (clos-slots-ref .slots. ,i)
883                                           (with-type-checked (,type ,safe-p)
884                                             ,value-form))))
885                              (not-boundp-form ()
886                                (if (member slotd sbuc-slots :test #'eq)
887                                    `(not (slot-boundp-using-class
888                                           ,class .instance. ,slotd))
889                                    `(eq (clos-slots-ref .slots. ,i)
890                                         +slot-unbound+))))
891                         (ecase kind
892                           ((nil)
893                            (unless early-unbound-markers-p
894                              `(setf (clos-slots-ref .slots. ,i)
895                                     +slot-unbound+)))
896                           ((param var)
897                            (setf-form value))
898                           (initfn
899                            (setf-form `(funcall ,value)))
900                           (initform/initfn
901                            (if early-unbound-markers-p
902                                `(when ,(not-boundp-form)
903                                   ,(setf-form `(funcall ,value)))
904                                (setf-form `(funcall ,value))))
905                           (initform
906                            (if early-unbound-markers-p
907                                `(when ,(not-boundp-form)
908                                   ,(setf-form `',(constant-form-value value)))
909                                (setf-form `',(constant-form-value value))))
910                           (constant
911                            (setf-form `',(constant-form-value value))))))))
912         ;; we are not allowed to modify QUOTEd locations, so we can't
913         ;; generate code like (setf (cdr ',location) arg).  Instead,
914         ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
915         ;; be bound to the location.
916         (multiple-value-bind (names locations class-init-forms)
917             (loop with names
918                   with locations
919                   with i = -1
920                   for (location kind value type slotd) in class-inits
921                   for init-form
922                      = (case kind
923                          (constant `',(constant-form-value value))
924                          ((param var) `,value)
925                          (initfn `(funcall ,value)))
926                   when (member slotd setf-svuc-slots :test #'eq)
927                   collect `(setf (slot-value-using-class
928                                   ,class .instance. ,slotd)
929                                  ,init-form)
930                   into class-init-forms
931                   else collect
932                      (let ((name (location-var-name (incf i))))
933                        (push name names)
934                        (push location locations)
935                        `(setf (cdr ,name)
936                               (with-type-checked (,type ,safe-p)
937                                 ,init-form)))
938                   into class-init-forms
939                   finally (return (values (nreverse names)
940                                           (nreverse locations)
941                                           class-init-forms)))
942           (multiple-value-bind (vars bindings)
943               (loop for (var . initfn) in (nreverse default-inits)
944                     collect var into vars
945                     collect `(,var (funcall ,initfn)) into bindings
946                     finally (return (values vars bindings)))
947             (values locations names
948                     bindings vars
949                     (nreverse defaulting-initargs)
950                     `(,@(delete nil instance-init-forms)
951                       ,@class-init-forms))))))))
952
953 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
954 ;;; telling, for each key in INITKEYS, which locations the initarg
955 ;;; initializes and the associated type with the location.  CLASS is
956 ;;; the class of the instance being initialized.
957 (defun compute-initarg-locations (class initkeys)
958   (loop with slots = (class-slots class)
959         for key in initkeys collect
960           (loop for slot in slots
961                 if (memq key (slot-definition-initargs slot))
962                   collect (list (slot-definition-location slot)
963                                 (slot-definition-type slot)
964                                 slot)
965                           into locations
966                 else
967                   collect slot into remaining-slots
968                 finally
969                   (setq slots remaining-slots)
970                   (return (cons key locations)))))
971
972 \f
973 ;;; *******************************
974 ;;; External Entry Points  ********
975 ;;; *******************************
976
977 (defun update-ctors (reason &key class name generic-function method)
978   (labels ((reset (class &optional initarg-caches-p (ctorsp t))
979              (when ctorsp
980                (dolist (ctor (plist-value class 'ctors))
981                  (install-initial-constructor ctor)))
982              (when initarg-caches-p
983                (dolist (cache '(mi-initargs ri-initargs))
984                  (setf (plist-value class cache) ())))
985              (dolist (subclass (class-direct-subclasses class))
986                (reset subclass initarg-caches-p ctorsp))))
987     (ecase reason
988       ;; CLASS must have been specified.
989       (finalize-inheritance
990        (reset class t))
991       ;; NAME must have been specified.
992       (setf-find-class
993        (loop for ctor in *all-ctors*
994              when (eq (ctor-class-or-name ctor) name) do
995              (when (ctor-class ctor)
996                (reset (ctor-class ctor)))
997              (loop-finish)))
998       ;; GENERIC-FUNCTION and METHOD must have been specified.
999       ((add-method remove-method)
1000        (flet ((class-of-1st-method-param (method)
1001                 (type-class (first (method-specializers method)))))
1002          (case (generic-function-name generic-function)
1003            ((make-instance allocate-instance)
1004             ;; FIXME: I can't see a way of working out which classes a
1005             ;; given metaclass specializer are applicable to short of
1006             ;; iterating and testing with class-of.  It would be good
1007             ;; to not invalidate caches of system classes at this
1008             ;; point (where it is not legal to define a method
1009             ;; applicable to them on system functions).  -- CSR,
1010             ;; 2010-07-13
1011             (reset (find-class 'standard-object) t t))
1012            ((initialize-instance shared-initialize)
1013             (reset (class-of-1st-method-param method) t t))
1014            ((reinitialize-instance)
1015             (reset (class-of-1st-method-param method) t nil))
1016            (t (when (or (eq (generic-function-name generic-function)
1017                             'slot-boundp-using-class)
1018                         (equal (generic-function-name generic-function)
1019                                '(setf slot-value-using-class)))
1020                 ;; this looks awfully expensive, but given that one
1021                 ;; can specialize on the SLOTD argument, nothing is
1022                 ;; safe.  -- CSR, 2004-07-12
1023                 (reset (find-class 'standard-object))))))))))
1024
1025 (defun precompile-ctors ()
1026   (dolist (ctor *all-ctors*)
1027     (when (null (ctor-class ctor))
1028       (let ((class (find-class (ctor-class-or-name ctor) nil)))
1029         (when (and class (class-finalized-p class))
1030           (install-optimized-constructor ctor))))))
1031
1032 (defun maybe-call-ctor (class initargs)
1033   (flet ((frob-initargs (ctor)
1034            (do ((ctail (ctor-initargs ctor))
1035                 (itail initargs)
1036                 (args nil))
1037                ((or (null ctail) (null itail))
1038                 (values (nreverse args) (and (null ctail) (null itail))))
1039              (unless (eq (pop ctail) (pop itail))
1040                (return nil))
1041              (let ((cval (pop ctail))
1042                    (ival (pop itail)))
1043                (if (constantp cval)
1044                    (unless (eql cval ival)
1045                      (return nil))
1046                    (push ival args))))))
1047     (dolist (ctor (plist-value class 'ctors))
1048       (when (eq (ctor-state ctor) 'optimized)
1049         (multiple-value-bind (ctor-args matchp)
1050             (frob-initargs ctor)
1051           (when matchp
1052             (return (apply ctor ctor-args))))))))
1053
1054 ;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
1055 (defun check-mi-initargs (class initargs)
1056   (let* ((class-proto (class-prototype class))
1057          (keys (plist-keys initargs))
1058          (cache (plist-value class 'mi-initargs))
1059          (cached (assoc keys cache :test #'equal))
1060          (invalid-keys
1061           (if (consp cached)
1062               (cdr cached)
1063               (let ((invalid
1064                      (check-initargs-1
1065                       class initargs
1066                       (list (list* 'allocate-instance class initargs)
1067                             (list* 'initialize-instance class-proto initargs)
1068                             (list* 'shared-initialize class-proto t initargs))
1069                       t nil)))
1070                 (setf (plist-value class 'mi-initargs)
1071                       (acons keys invalid cache))
1072                 invalid))))
1073     (when invalid-keys
1074       ;; FIXME: should have an operation here, and maybe a set of
1075       ;; valid keys.
1076       (error 'initarg-error :class class :initargs invalid-keys))))
1077
1078 (defun check-ri-initargs (instance initargs)
1079   (let* ((class (class-of instance))
1080          (keys (plist-keys initargs))
1081          (cache (plist-value class 'ri-initargs))
1082          (cached (assoc keys cache :test #'equal))
1083          (invalid-keys
1084           (if (consp cached)
1085               (cdr cached)
1086               (let ((invalid
1087                      ;; FIXME: give CHECK-INITARGS-1 and friends a
1088                      ;; more mnemonic name and (possibly) a nicer,
1089                      ;; more orthogonal interface.
1090                      (check-initargs-1
1091                       class initargs
1092                       (list (list* 'reinitialize-instance instance initargs)
1093                             (list* 'shared-initialize instance nil initargs))
1094                       t nil)))
1095                 (setf (plist-value class 'ri-initargs)
1096                       (acons keys invalid cache))
1097                 invalid))))
1098     (when invalid-keys
1099       (error 'initarg-error :class class :initargs invalid-keys))))
1100
1101 ;;; end of ctor.lisp