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   (list* 'ctor class-name safe-code-p initargs))
 156
 157 ;;; Keep this a separate function for testing.
 158 (defun ensure-ctor (function-name class-name initargs safe-code-p)
 159   (with-world-lock ()
 160     (if (fboundp function-name)
 161         (the ctor (fdefinition function-name))
 162         (make-ctor function-name class-name initargs safe-code-p))))
 163
 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)
 171       ctor)))
 172 \f
 173 ;;; *****************
 174 ;;; Inline CTOR cache
 175 ;;; *****************
 176 ;;;
 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.
 180
 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
 186 ;;; the same list.
 187 (defun find-ctor (key list)
 188   (labels ((walk (tail from-head depth)
 189              (declare (fixnum depth))
 190              (if tail
 191                  (let ((ctor (car tail)))
 192                    (if (eq (ctor-class-or-name ctor) key)
 193                        (if (> depth 3)
 194                            (values ctor
 195                                    (nconc (list ctor) (nreverse from-head) (cdr tail)))
 196                            (values ctor
 197                                    list))
 198                        (walk (cdr tail)
 199                              (cons ctor from-head)
 200                              (logand #xf (1+ depth)))))
 201                  (values nil list))))
 202     (walk list nil 0)))
 203
 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))
 209         (t
 210          (bug "Something strange where symbol or class expected."))))
 211
 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)
 220 ;;; and rehash.
 221 (defconstant +ctor-table-max-probe-depth+ 5)
 222
 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))))
 229
 230 (declaim (inline mix-ctor-hash))
 231 (defun mix-ctor-hash (hash base)
 232   (logand most-positive-fixnum (+ hash base 1)))
 233
 234 (defun put-ctor (ctor table)
 235   (cond ((try-put-ctor ctor table)
 236          (values ctor table))
 237         (t
 238          (expand-ctor-table ctor table))))
 239
 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
 244 ;;; that time.
 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))
 249          (hash base)
 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)))
 257                      (t
 258                       (setf (aref table index) ctor)
 259                       (return-from try-put-ctor t)))))
 260     ;; Didn't fit, must expand
 261     nil))
 262
 263 (defun get-ctor (class table)
 264   (declare (simple-vector table) (optimize speed))
 265   (let* ((base (sxhash-symbol-or-class class))
 266          (hash base)
 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)))))
 275     ;; Nothing.
 276     nil))
 277
 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
 281 ;;; too.
 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))
 287     (tagbody
 288      :again
 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
 292                            ;; there.
 293                            (randomly-punting-lambda (old-ctor)
 294                              (try-put-ctor old-ctor new))
 295                            (lambda (old-ctor)
 296                              (unless (try-put-ctor old-ctor new)
 297                                (if max-size-p
 298                                    (setf drop-random-entries t)
 299                                    (setf new-size (* 2 new-size)))
 300                                (go :again))))))
 301            (aver (try-put-ctor ctor new))
 302            (dotimes (i old-size)
 303              (let ((old-ctor (aref old i)))
 304                (when old-ctor
 305                  (funcall action old-ctor))))
 306            (return-from expand-ctor-table (values ctor new)))))))
 307
 308 (defun ctor-list-to-table (list)
 309   (let ((table (make-ctor-table (length list))))
 310     (dolist (ctor list)
 311       (setf table (nth-value 1 (put-ctor ctor table))))
 312     table))
 313
 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)
 322                            (let (mi-initargs)
 323                              (doplist (key value) initargs
 324                                (push key mi-initargs)
 325                                (push (if (constantp value)
 326                                          value
 327                                          (pop ctor-parameters))
 328                                      mi-initargs))
 329                              (apply #'make-instance class-name (nreverse mi-initargs))))
 330                          store)))))
 331     (if (listp store)
 332         (multiple-value-bind (ctor list) (find-ctor class-name store)
 333           (if ctor
 334               (values ctor list)
 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)))
 340          (if ctor
 341              (values ctor store)
 342              (put-ctor (maybe-ctor-for-caching) store))))))
 343 \f
 344 ;;; ***********************************************
 345 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
 346 ;;; ***********************************************
 347
 348 (defvar *compiling-optimized-constructor* nil)
 349
 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)))
 357       form))
 358
 359 (defun make-instance->constructor-call (form safe-code-p)
 360   (destructuring-bind (class-arg &rest args) (cdr form)
 361     (flet (;;
 362            ;; Return the name of parameter number I of a constructor
 363            ;; function.
 364            (parameter-name (i)
 365              (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.)))
 366                (if (array-in-bounds-p ps i)
 367                    (aref ps i)
 368                    (format-symbol *pcl-package* ".P~D." i))))
 369            ;; Check if CLASS-ARG is a constant symbol.  Give up if
 370            ;; not.
 371            (constant-class-p ()
 372              (and class-arg (constant-class-arg-p class-arg)))
 373            ;; Check if ARGS are suitable for an optimized constructor.
 374            ;; Return NIL from the outer function if not.
 375            (check-args ()
 376              (loop for (key . more) on args by #'cddr do
 377                       (when (or (null more)
 378                                 (not (constant-symbol-p key))
 379                                 (eq :allow-other-keys (constant-form-value key)))
 380                         (return-from make-instance->constructor-call nil)))))
 381       (check-args)
 382       ;; Collect a plist of initargs and constant values/parameter names
 383       ;; in INITARGS.  Collect non-constant initialization forms in
 384       ;; VALUE-FORMS.
 385       (multiple-value-bind (initargs value-forms)
 386           (loop for (key value) on args by #'cddr and i from 0
 387                 collect (constant-form-value key) into initargs
 388                 if (constantp value)
 389                 collect value into initargs
 390                 else
 391                 collect (parameter-name i) into initargs
 392                 and collect value into value-forms
 393                 finally
 394                 (return (values initargs value-forms)))
 395         (if (constant-class-p)
 396             (let* ((class-or-name (constant-form-value class-arg))
 397                    (function-name (make-ctor-function-name class-or-name initargs
 398                                                            safe-code-p)))
 399               ;; Prevent compiler warnings for calling the ctor.
 400               (proclaim-as-fun-name function-name)
 401               (note-name-defined function-name :function)
 402               (when (eq (info :function :where-from function-name) :assumed)
 403                 (setf (info :function :where-from function-name) :defined)
 404                 (when (info :function :assumed-type function-name)
 405                   (setf (info :function :assumed-type function-name) nil)))
 406               ;; Return code constructing a ctor at load time, which,
 407               ;; when called, will set its funcallable instance
 408               ;; function to an optimized constructor function.
 409               `(locally
 410                    (declare (disable-package-locks ,function-name))
 411                  (let ((.x. (load-time-value
 412                              (ensure-ctor ',function-name ',class-or-name ',initargs
 413                                           ',safe-code-p))))
 414                    (declare (ignore .x.))
 415                    ;; ??? check if this is worth it.
 416                    (declare
 417                     (ftype (or (function ,(make-list (length value-forms)
 418                                                      :initial-element t)
 419                                          t)
 420                                (function (&rest t) t))
 421                            ,function-name))
 422                    (funcall (function ,function-name) ,@value-forms))))
 423             (when (and class-arg (not (constantp class-arg)))
 424               ;; Build an inline cache: a CONS, with the actual cache
 425               ;; in the CDR.
 426               `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
 427                                                         make-instance))
 428                  (let* ((.cache. (load-time-value (cons 'ctor-cache nil)))
 429                         (.store. (cdr .cache.))
 430                         (.class-arg. ,class-arg))
 431                    (multiple-value-bind (.fun. .new-store.)
 432                        (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p)
 433                      ;; Thread safe: if multiple threads hit this in
 434                      ;; parallel, the update from the other one is
 435                      ;; just lost -- no harm done, except for the need
 436                      ;; to redo the work next time.
 437                      (unless (eq .store. .new-store.)
 438                        (setf (cdr .cache.) .new-store.))
 439                      (funcall (truly-the function .fun.) ,@value-forms))))))))))
 440 \f
 441 ;;; **************************************************
 442 ;;; Load-Time Constructor Function Generation  *******
 443 ;;; **************************************************
 444
 445 ;;; The system-supplied primary INITIALIZE-INSTANCE and
 446 ;;; SHARED-INITIALIZE methods.  One cannot initialize these variables
 447 ;;; to the right values here because said functions don't exist yet
 448 ;;; when this file is first loaded.
 449 (defvar *the-system-ii-method* nil)
 450 (defvar *the-system-si-method* nil)
 451
 452 (defun install-optimized-constructor (ctor)
 453   (with-world-lock ()
 454     (let* ((class-or-name (ctor-class-or-name ctor))
 455            (class (if (symbolp class-or-name)
 456                       (find-class class-or-name)
 457                       class-or-name)))
 458       (unless (class-finalized-p class)
 459         (finalize-inheritance class))
 460       ;; We can have a class with an invalid layout here.  Such a class
 461       ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE
 462       ;; ...), because part of the deal is that those only happen from
 463       ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
 464       ;; class.  An invalid layout of T needs to be flushed, however.
 465       (when (eq (layout-invalid (class-wrapper class)) t)
 466         (%force-cache-flushes class))
 467       (setf (ctor-class ctor) class)
 468       (pushnew ctor (plist-value class 'ctors) :test #'eq)
 469       (multiple-value-bind (form locations names optimizedp)
 470           (constructor-function-form ctor)
 471         (setf (funcallable-instance-fun ctor)
 472               (apply
 473                (let ((*compiling-optimized-constructor* t))
 474                  (handler-bind ((compiler-note #'muffle-warning))
 475                    (compile nil `(lambda ,names ,form))))
 476                locations)
 477               (ctor-state ctor) (if optimizedp 'optimized 'fallback))))))
 478
 479 (defun constructor-function-form (ctor)
 480   (let* ((class (ctor-class ctor))
 481          (proto (class-prototype class))
 482          (make-instance-methods
 483           (compute-applicable-methods #'make-instance (list class)))
 484          (allocate-instance-methods
 485           (compute-applicable-methods #'allocate-instance (list class)))
 486          ;; I stared at this in confusion for a while, thinking
 487          ;; carefully about the possibility of the class prototype not
 488          ;; being of sufficient discrimiating power, given the
 489          ;; possibility of EQL-specialized methods on
 490          ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE.  However, given
 491          ;; that this is a constructor optimization, the user doesn't
 492          ;; yet have the instance to create a method with such an EQL
 493          ;; specializer.
 494          ;;
 495          ;; There remains the (theoretical) possibility of someone
 496          ;; coming along with code of the form
 497          ;;
 498          ;; (defmethod initialize-instance :before ((o foo) ...)
 499          ;;   (eval `(defmethod shared-initialize :before ((o foo) ...) ...)))
 500          ;;
 501          ;; but probably we can afford not to worry about this too
 502          ;; much for now.  -- CSR, 2004-07-12
 503          (ii-methods
 504           (compute-applicable-methods #'initialize-instance (list proto)))
 505          (si-methods
 506           (compute-applicable-methods #'shared-initialize (list proto t)))
 507          (setf-svuc-slots-methods
 508           (loop for slot in (class-slots class)
 509                 collect (compute-applicable-methods
 510                          #'(setf slot-value-using-class)
 511                          (list nil class proto slot))))
 512          (sbuc-slots-methods
 513           (loop for slot in (class-slots class)
 514                 collect (compute-applicable-methods
 515                          #'slot-boundp-using-class
 516                          (list class proto slot)))))
 517     ;; Cannot initialize these variables earlier because the generic
 518     ;; functions don't exist when PCL is built.
 519     (when (null *the-system-si-method*)
 520       (setq *the-system-si-method*
 521             (find-method #'shared-initialize
 522                          () (list *the-class-slot-object* *the-class-t*)))
 523       (setq *the-system-ii-method*
 524             (find-method #'initialize-instance
 525                          () (list *the-class-slot-object*))))
 526     ;; Note that when there are user-defined applicable methods on
 527     ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
 528     ;; together with the system-defined ones in what
 529     ;; COMPUTE-APPLICABLE-METHODS returns.
 530     (let ((maybe-invalid-initargs
 531            (check-initargs-1
 532             class
 533             (append
 534              (ctor-default-initkeys
 535               (ctor-initargs ctor) (class-default-initargs class))
 536              (plist-keys (ctor-initargs ctor)))
 537             (append ii-methods si-methods) nil nil))
 538           (custom-make-instance
 539            (not (null (cdr make-instance-methods)))))
 540       (if (and (not (structure-class-p class))
 541                (not (condition-class-p class))
 542                (not custom-make-instance)
 543                (null (cdr allocate-instance-methods))
 544                (every (lambda (x)
 545                         (member (slot-definition-allocation x)
 546                                 '(:instance :class)))
 547                       (class-slots class))
 548                (not maybe-invalid-initargs)
 549                (not (around-or-nonstandard-primary-method-p
 550                      ii-methods *the-system-ii-method*))
 551                (not (around-or-nonstandard-primary-method-p
 552                      si-methods *the-system-si-method*))
 553                ;; the instance structure protocol goes through
 554                ;; slot-value(-using-class) and friends (actually just
 555                ;; (SETF SLOT-VALUE-USING-CLASS) and
 556                ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
 557                ;; applicable methods we can't shortcircuit them.
 558                (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
 559                (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
 560           (optimizing-generator ctor ii-methods si-methods)
 561           (fallback-generator ctor ii-methods si-methods
 562                               (or maybe-invalid-initargs custom-make-instance))))))
 563
 564 (defun around-or-nonstandard-primary-method-p
 565     (methods &optional standard-method)
 566   (loop with primary-checked-p = nil
 567         for method in methods
 568         as qualifiers = (if (consp method)
 569                             (early-method-qualifiers method)
 570                             (safe-method-qualifiers method))
 571         when (or (eq :around (car qualifiers))
 572                  (and (null qualifiers)
 573                       (not primary-checked-p)
 574                       (not (null standard-method))
 575                       (not (eq standard-method method))))
 576           return t
 577         when (null qualifiers) do
 578           (setq primary-checked-p t)))
 579
 580 (defun fallback-generator (ctor ii-methods si-methods use-make-instance)
 581   (declare (ignore ii-methods si-methods))
 582   (let ((class (ctor-class ctor))
 583         (lambda-list (make-ctor-parameter-list ctor))
 584         (initargs (quote-plist-keys (ctor-initargs ctor))))
 585     (if use-make-instance
 586         `(lambda ,lambda-list
 587            (declare #.*optimize-speed*)
 588            ;; The CTOR MAKE-INSTANCE optimization checks for
 589            ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
 590            ;; compilation of the constructor, hence avoiding the
 591            ;; possibility of endless recursion.
 592            (make-instance ,class ,@initargs))
 593         (let ((defaults (class-default-initargs class)))
 594           (when defaults
 595             (setf initargs (ctor-default-initargs initargs defaults)))
 596           `(lambda ,lambda-list
 597              (declare #.*optimize-speed*)
 598              (fast-make-instance ,class ,@initargs))))))
 599
 600 ;;; Not as good as the real optimizing generator, but faster than going
 601 ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
 602 (defun fast-make-instance (class &rest initargs)
 603   (declare #.*optimize-speed*)
 604   (declare (dynamic-extent initargs))
 605   (let ((.instance. (apply #'allocate-instance class initargs)))
 606     (apply #'initialize-instance .instance. initargs)
 607     .instance.))
 608
 609 (defun optimizing-generator (ctor ii-methods si-methods)
 610   (multiple-value-bind (locations names body before-method-p)
 611       (fake-initialization-emf ctor ii-methods si-methods)
 612     (let ((wrapper (class-wrapper (ctor-class ctor))))
 613       (values
 614        `(lambda ,(make-ctor-parameter-list ctor)
 615          (declare #.*optimize-speed*)
 616          (block nil
 617            (when (layout-invalid ,wrapper)
 618              (install-initial-constructor ,ctor)
 619              (return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
 620            ,(wrap-in-allocate-forms ctor body before-method-p)))
 621        locations
 622        names
 623        t))))
 624
 625 ;;; Return a form wrapped around BODY that allocates an instance
 626 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
 627 ;;; before-methods, in which case we initialize instance slots to
 628 ;;; +SLOT-UNBOUND+.  The resulting form binds the local variables
 629 ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot
 630 ;;; vector around BODY.
 631 (defun wrap-in-allocate-forms (ctor body before-method-p)
 632   (let* ((class (ctor-class ctor))
 633          (wrapper (class-wrapper class))
 634          (allocation-function (raw-instance-allocator class))
 635          (slots-fetcher (slots-fetcher class)))
 636     (if (eq allocation-function 'allocate-standard-instance)
 637         `(let ((.instance. (%make-standard-instance nil
 638                                                     (get-instance-hash-code)))
 639                (.slots. (make-array
 640                          ,(layout-length wrapper)
 641                          ,@(when before-method-p
 642                              '(:initial-element +slot-unbound+)))))
 643            (setf (std-instance-wrapper .instance.) ,wrapper)
 644            (setf (std-instance-slots .instance.) .slots.)
 645            ,body
 646            .instance.)
 647         `(let* ((.instance. (,allocation-function ,wrapper))
 648                 (.slots. (,slots-fetcher .instance.)))
 649            (declare (ignorable .slots.))
 650            ,body
 651            .instance.))))
 652
 653 ;;; Return a form for invoking METHOD with arguments from ARGS.  As
 654 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
 655 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...).  We could
 656 ;;; call fast method functions directly here, but benchmarks show that
 657 ;;; there's no speed to gain, so lets avoid the hair here.
 658 (defmacro invoke-method (method args)
 659   `(funcall ,(method-function method) ,args ()))
 660
 661 ;;; Return a form that is sort of an effective method comprising all
 662 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
 663 ;;; normally have taken place when calling MAKE-INSTANCE.
 664 (defun fake-initialization-emf (ctor ii-methods si-methods)
 665   (multiple-value-bind (ii-around ii-before ii-primary ii-after)
 666       (standard-sort-methods ii-methods)
 667     (declare (ignore ii-primary))
 668     (multiple-value-bind (si-around si-before si-primary si-after)
 669         (standard-sort-methods si-methods)
 670       (declare (ignore si-primary))
 671       (aver (and (null ii-around) (null si-around)))
 672       (let ((initargs (ctor-initargs ctor)))
 673         (multiple-value-bind (locations names bindings vars defaulting-initargs body)
 674             (slot-init-forms ctor (or ii-before si-before))
 675         (values
 676          locations
 677          names
 678          `(let ,bindings
 679            (declare (ignorable ,@vars))
 680            (let (,@(when (or ii-before ii-after)
 681                      `((.ii-args.
 682                         (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs))))
 683                  ,@(when (or si-before si-after)
 684                      `((.si-args.
 685                         (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs)))))
 686             ,@(loop for method in ii-before
 687                     collect `(invoke-method ,method .ii-args.))
 688             ,@(loop for method in si-before
 689                     collect `(invoke-method ,method .si-args.))
 690             ,@body
 691             ,@(loop for method in si-after
 692                     collect `(invoke-method ,method .si-args.))
 693             ,@(loop for method in ii-after
 694                     collect `(invoke-method ,method .ii-args.))))
 695          (or ii-before si-before)))))))
 696
 697 ;;; Return four values from APPLICABLE-METHODS: around methods, before
 698 ;;; methods, the applicable primary method, and applicable after
 699 ;;; methods.  Before and after methods are sorted in the order they
 700 ;;; must be called.
 701 (defun standard-sort-methods (applicable-methods)
 702   (loop for method in applicable-methods
 703         as qualifiers = (if (consp method)
 704                             (early-method-qualifiers method)
 705                             (safe-method-qualifiers method))
 706         if (null qualifiers)
 707           collect method into primary
 708         else if (eq :around (car qualifiers))
 709           collect method into around
 710         else if (eq :after (car qualifiers))
 711           collect method into after
 712         else if (eq :before (car qualifiers))
 713           collect method into before
 714         finally
 715           (return (values around before (first primary) (reverse after)))))
 716
 717 (defmacro with-type-checked ((type safe-p) &body body)
 718   (if safe-p
 719       ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
 720       ;; THE instead of e.g. CHECK-TYPE.
 721       `(locally
 722            (declare (optimize (safety 3)))
 723          (the ,type (progn ,@body)))
 724       `(progn ,@body)))
 725
 726 ;;; Return as multiple values bindings for default initialization
 727 ;;; arguments, variable names, defaulting initargs and a body for
 728 ;;; initializing instance and class slots of an object costructed by
 729 ;;; CTOR.  The variable .SLOTS. is assumed to bound to the instance's
 730 ;;; slot vector.  BEFORE-METHOD-P T means before-methods will be
 731 ;;; called, which means that 1) other code will initialize instance
 732 ;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and
 733 ;;; that we have to check if these before-methods have set slots.
 734 (defun slot-init-forms (ctor before-method-p)
 735   (let* ((class (ctor-class ctor))
 736          (initargs (ctor-initargs ctor))
 737          (initkeys (plist-keys initargs))
 738          (safe-p (ctor-safe-p ctor))
 739          (slot-vector
 740           (make-array (layout-length (class-wrapper class))
 741                       :initial-element nil))
 742          (class-inits ())
 743          (default-inits ())
 744          (defaulting-initargs ())
 745          (default-initargs (class-default-initargs class))
 746          (initarg-locations
 747           (compute-initarg-locations
 748            class (append initkeys (mapcar #'car default-initargs)))))
 749     (labels ((initarg-locations (initarg)
 750                (cdr (assoc initarg initarg-locations :test #'eq)))
 751              (initializedp (location)
 752                (cond
 753                  ((consp location)
 754                   (assoc location class-inits :test #'eq))
 755                  ((integerp location)
 756                   (not (null (aref slot-vector location))))
 757                  (t (bug "Weird location in ~S" 'slot-init-forms))))
 758              (class-init (location kind val type)
 759                (aver (consp location))
 760                (unless (initializedp location)
 761                  (push (list location kind val type) class-inits)))
 762              (instance-init (location kind val type)
 763                (aver (integerp location))
 764                (unless (initializedp location)
 765                  (setf (aref slot-vector location) (list kind val type))))
 766              (default-init-var-name (i)
 767                (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
 768                  (if (array-in-bounds-p ps i)
 769                      (aref ps i)
 770                      (format-symbol *pcl-package* ".D~D." i))))
 771              (location-var-name (i)
 772                (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.)))
 773                  (if (array-in-bounds-p ls i)
 774                      (aref ls i)
 775                      (format-symbol *pcl-package* ".L~D." i)))))
 776       ;; Loop over supplied initargs and values and record which
 777       ;; instance and class slots they initialize.
 778       (loop for (key value) on initargs by #'cddr
 779             as kind = (if (constantp value) 'constant 'param)
 780             as locations = (initarg-locations key)
 781             do (loop for (location . type) in locations
 782                      do (if (consp location)
 783                             (class-init location kind value type)
 784                             (instance-init location kind value type))))
 785       ;; Loop over default initargs of the class, recording
 786       ;; initializations of slots that have not been initialized
 787       ;; above.  Default initargs which are not in the supplied
 788       ;; initargs are treated as if they were appended to supplied
 789       ;; initargs, that is, their values must be evaluated even
 790       ;; if not actually used for initializing a slot.
 791       (loop for (key initform initfn) in default-initargs and i from 0
 792             unless (member key initkeys :test #'eq)
 793             do (let* ((kind (if (constantp initform) 'constant 'var))
 794                       (init (if (eq kind 'var) initfn initform)))
 795                  (ecase kind
 796                    (constant
 797                     (push (list 'quote key) defaulting-initargs)
 798                     (push initform defaulting-initargs))
 799                    (var
 800                     (push (list 'quote key) defaulting-initargs)
 801                     (push (default-init-var-name i) defaulting-initargs)))
 802               (when (eq kind 'var)
 803                 (let ((init-var (default-init-var-name i)))
 804                   (setq init init-var)
 805                   (push (cons init-var initfn) default-inits)))
 806               (loop for (location . type) in (initarg-locations key)
 807                     do (if (consp location)
 808                            (class-init location kind init type)
 809                            (instance-init location kind init type)))))
 810       ;; Loop over all slots of the class, filling in the rest from
 811       ;; slot initforms.
 812       (loop for slotd in (class-slots class)
 813             as location = (slot-definition-location slotd)
 814             as type = (slot-definition-type slotd)
 815             as allocation = (slot-definition-allocation slotd)
 816             as initfn = (slot-definition-initfunction slotd)
 817             as initform = (slot-definition-initform slotd) do
 818               (unless (or (eq allocation :class)
 819                           (null initfn)
 820                           (initializedp location))
 821                 (if (constantp initform)
 822                     (instance-init location 'initform initform type)
 823                     (instance-init location 'initform/initfn initfn type))))
 824       ;; Generate the forms for initializing instance and class slots.
 825       (let ((instance-init-forms
 826              (loop for slot-entry across slot-vector and i from 0
 827                    as (kind value type) = slot-entry collect
 828                      (ecase kind
 829                        ((nil)
 830                         (unless before-method-p
 831                           `(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
 832                        ((param var)
 833                         `(setf (clos-slots-ref .slots. ,i)
 834                                (with-type-checked (,type ,safe-p)
 835                                    ,value)))
 836                        (initfn
 837                         `(setf (clos-slots-ref .slots. ,i)
 838                                (with-type-checked (,type ,safe-p)
 839                                  (funcall ,value))))
 840                        (initform/initfn
 841                         (if before-method-p
 842                             `(when (eq (clos-slots-ref .slots. ,i)
 843                                        +slot-unbound+)
 844                                (setf (clos-slots-ref .slots. ,i)
 845                                      (with-type-checked (,type ,safe-p)
 846                                        (funcall ,value))))
 847                             `(setf (clos-slots-ref .slots. ,i)
 848                                    (with-type-checked (,type ,safe-p)
 849                                      (funcall ,value)))))
 850                        (initform
 851                         (if before-method-p
 852                             `(when (eq (clos-slots-ref .slots. ,i)
 853                                        +slot-unbound+)
 854                                (setf (clos-slots-ref .slots. ,i)
 855                                      (with-type-checked (,type ,safe-p)
 856                                        ',(constant-form-value value))))
 857                             `(setf (clos-slots-ref .slots. ,i)
 858                                    (with-type-checked (,type ,safe-p)
 859                                      ',(constant-form-value value)))))
 860                        (constant
 861                         `(setf (clos-slots-ref .slots. ,i)
 862                                (with-type-checked (,type ,safe-p)
 863                                  ',(constant-form-value value))))))))
 864         ;; we are not allowed to modify QUOTEd locations, so we can't
 865         ;; generate code like (setf (cdr ',location) arg).  Instead,
 866         ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
 867         ;; be bound to the location.
 868         (multiple-value-bind (names locations class-init-forms)
 869             (loop for (location kind value type) in class-inits
 870                   for i upfrom 0
 871                   for name = (location-var-name i)
 872                   collect name into names
 873                   collect location into locations
 874                   collect `(setf (cdr ,name)
 875                                  (with-type-checked (,type ,safe-p)
 876                                    ,(case kind
 877                                           (constant `',(constant-form-value value))
 878                                           ((param var) `,value)
 879                                           (initfn `(funcall ,value)))))
 880                   into class-init-forms
 881                   finally (return (values names locations class-init-forms)))
 882           (multiple-value-bind (vars bindings)
 883               (loop for (var . initfn) in (nreverse default-inits)
 884                     collect var into vars
 885                     collect `(,var (funcall ,initfn)) into bindings
 886                     finally (return (values vars bindings)))
 887             (values locations names
 888                     bindings vars
 889                     (nreverse defaulting-initargs)
 890                     `(,@(delete nil instance-init-forms)
 891                       ,@class-init-forms))))))))
 892
 893 ;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
 894 ;;; telling, for each key in INITKEYS, which locations the initarg
 895 ;;; initializes and the associated type with the location.  CLASS is
 896 ;;; the class of the instance being initialized.
 897 (defun compute-initarg-locations (class initkeys)
 898   (loop with slots = (class-slots class)
 899         for key in initkeys collect
 900           (loop for slot in slots
 901                 if (memq key (slot-definition-initargs slot))
 902                   collect (cons (slot-definition-location slot)
 903                                 (slot-definition-type slot))
 904                           into locations
 905                 else
 906                   collect slot into remaining-slots
 907                 finally
 908                   (setq slots remaining-slots)
 909                   (return (cons key locations)))))
 910
 911 \f
 912 ;;; *******************************
 913 ;;; External Entry Points  ********
 914 ;;; *******************************
 915
 916 (defun update-ctors (reason &key class name generic-function method)
 917   (labels ((reset (class &optional initarg-caches-p (ctorsp t))
 918              (when ctorsp
 919                (dolist (ctor (plist-value class 'ctors))
 920                  (install-initial-constructor ctor)))
 921              (when initarg-caches-p
 922                (dolist (cache '(mi-initargs ri-initargs))
 923                  (setf (plist-value class cache) ())))
 924              (dolist (subclass (class-direct-subclasses class))
 925                (reset subclass initarg-caches-p ctorsp))))
 926     (ecase reason
 927       ;; CLASS must have been specified.
 928       (finalize-inheritance
 929        (reset class t))
 930       ;; NAME must have been specified.
 931       (setf-find-class
 932        (loop for ctor in *all-ctors*
 933              when (eq (ctor-class-or-name ctor) name) do
 934              (when (ctor-class ctor)
 935                (reset (ctor-class ctor)))
 936              (loop-finish)))
 937       ;; GENERIC-FUNCTION and METHOD must have been specified.
 938       ((add-method remove-method)
 939        (flet ((class-of-1st-method-param (method)
 940                 (type-class (first (method-specializers method)))))
 941          (case (generic-function-name generic-function)
 942            ((make-instance allocate-instance)
 943             ;; FIXME: I can't see a way of working out which classes a
 944             ;; given metaclass specializer are applicable to short of
 945             ;; iterating and testing with class-of.  It would be good
 946             ;; to not invalidate caches of system classes at this
 947             ;; point (where it is not legal to define a method
 948             ;; applicable to them on system functions).  -- CSR,
 949             ;; 2010-07-13
 950             (reset (find-class 'standard-object) t t))
 951            ((initialize-instance shared-initialize)
 952             (reset (class-of-1st-method-param method) t t))
 953            ((reinitialize-instance)
 954             (reset (class-of-1st-method-param method) t nil))
 955            (t (when (or (eq (generic-function-name generic-function)
 956                             'slot-boundp-using-class)
 957                         (equal (generic-function-name generic-function)
 958                                '(setf slot-value-using-class)))
 959                 ;; this looks awfully expensive, but given that one
 960                 ;; can specialize on the SLOTD argument, nothing is
 961                 ;; safe.  -- CSR, 2004-07-12
 962                 (reset (find-class 'standard-object))))))))))
 963
 964 (defun precompile-ctors ()
 965   (dolist (ctor *all-ctors*)
 966     (when (null (ctor-class ctor))
 967       (let ((class (find-class (ctor-class-or-name ctor) nil)))
 968         (when (and class (class-finalized-p class))
 969           (install-optimized-constructor ctor))))))
 970
 971 (defun maybe-call-ctor (class initargs)
 972   (flet ((frob-initargs (ctor)
 973            (do ((ctail (ctor-initargs ctor))
 974                 (itail initargs)
 975                 (args nil))
 976                ((or (null ctail) (null itail))
 977                 (values (nreverse args) (and (null ctail) (null itail))))
 978              (unless (eq (pop ctail) (pop itail))
 979                (return nil))
 980              (let ((cval (pop ctail))
 981                    (ival (pop itail)))
 982                (if (constantp cval)
 983                    (unless (eql cval ival)
 984                      (return nil))
 985                    (push ival args))))))
 986     (dolist (ctor (plist-value class 'ctors))
 987       (when (eq (ctor-state ctor) 'optimized)
 988         (multiple-value-bind (ctor-args matchp)
 989             (frob-initargs ctor)
 990           (when matchp
 991             (return (apply ctor ctor-args))))))))
 992
 993 ;;; FIXME: CHECK-FOO-INITARGS share most of their bodies.
 994 (defun check-mi-initargs (class initargs)
 995   (let* ((class-proto (class-prototype class))
 996          (keys (plist-keys initargs))
 997          (cache (plist-value class 'mi-initargs))
 998          (cached (assoc keys cache :test #'equal))
 999          (invalid-keys
1000           (if (consp cached)
1001               (cdr cached)
1002               (let ((invalid
1003                      (check-initargs-1
1004                       class initargs
1005                       (list (list* 'allocate-instance class initargs)
1006                             (list* 'initialize-instance class-proto initargs)
1007                             (list* 'shared-initialize class-proto t initargs))
1008                       t nil)))
1009                 (setf (plist-value class 'mi-initargs)
1010                       (acons keys invalid cache))
1011                 invalid))))
1012     (when invalid-keys
1013       ;; FIXME: should have an operation here, and maybe a set of
1014       ;; valid keys.
1015       (error 'initarg-error :class class :initargs invalid-keys))))
1016
1017 (defun check-ri-initargs (instance initargs)
1018   (let* ((class (class-of instance))
1019          (keys (plist-keys initargs))
1020          (cache (plist-value class 'ri-initargs))
1021          (cached (assoc keys cache :test #'equal))
1022          (invalid-keys
1023           (if (consp cached)
1024               (cdr cached)
1025               (let ((invalid
1026                      ;; FIXME: give CHECK-INITARGS-1 and friends a
1027                      ;; more mnemonic name and (possibly) a nicer,
1028                      ;; more orthogonal interface.
1029                      (check-initargs-1
1030                       class initargs
1031                       (list (list* 'reinitialize-instance instance initargs)
1032                             (list* 'shared-initialize instance nil initargs))
1033                       t nil)))
1034                 (setf (plist-value class 'ri-initargs)
1035                       (acons keys invalid cache))
1036                 invalid))))
1037     (when invalid-keys
1038       (error 'initarg-error :class class :initargs invalid-keys))))
1039
1040 ;;; end of ctor.lisp