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