X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=06b69ddfc555651797f8fbba341afbe22e6f84b2;hb=cea2946076e0dac11eea1c95158e5e2326455dd8;hp=92965bfdb89d2fdcadf900a1ead217d54c40ec63;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 92965bf..06b69dd 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -84,18 +84,35 @@ else if (or (null test) (funcall test (car more))) collect (car more))) +(defun constant-class-arg-p (form) + (and (constantp form) + (let ((constant (constant-form-value form))) + (or (and (symbolp constant) + (not (null (symbol-package constant)))) + (classp form))))) + (defun constant-symbol-p (form) (and (constantp form) - (let ((constant (eval form))) + (let ((constant (constant-form-value form))) (and (symbolp constant) (not (null (symbol-package constant))))))) -;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just -;;; collecting the defaulted initargs for the call. +;;; Somewhat akin to DEFAULT-INITARGS, but just collecting the defaulted +;;; initargs for the call. (defun ctor-default-initkeys (supplied-initargs class-default-initargs) (loop for (key) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) collect key)) + +;;; Like DEFAULT-INITARGS, but return a list that can be spliced into source, +;;; instead of a list with values already evaluated. +(defun ctor-default-initargs (supplied-initargs class-default-initargs) + (loop for (key form fun) in class-default-initargs + when (eq (getf supplied-initargs key '.not-there.) '.not-there.) + append (list key (if (constantp form) form `(funcall ,fun))) + into default-initargs + finally + (return (append supplied-initargs default-initargs)))) ;;; ***************** ;;; CTORS ********* @@ -107,16 +124,15 @@ ;;; funcallable instance is set to it. ;;; (!defstruct-with-alternate-metaclass ctor - :slot-names (function-name class-name class initargs) + :slot-names (function-name class-or-name class initargs state safe-p) :boa-constructor %make-ctor - :superclass-name pcl-funcallable-instance - :metaclass-name random-pcl-classoid - :metaclass-constructor make-random-pcl-classoid + :superclass-name function + :metaclass-name static-classoid + :metaclass-constructor make-static-classoid :dd-type funcallable-structure :runtime-type-checks-p nil) ;;; List of all defined ctors. - (defvar *all-ctors* ()) (defun make-ctor-parameter-list (ctor) @@ -126,44 +142,222 @@ ;;; optimized constructor function when called. (defun install-initial-constructor (ctor &key force-p) (when (or force-p (ctor-class ctor)) - (setf (ctor-class ctor) nil) + (setf (ctor-class ctor) nil + (ctor-state ctor) 'initial) (setf (funcallable-instance-fun ctor) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (install-optimized-constructor ctor) (apply ctor args))) (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -(defun make-ctor-function-name (class-name initargs) - (list* 'ctor class-name initargs)) +(defun make-ctor-function-name (class-name initargs safe-code-p) + (list* 'ctor class-name safe-code-p initargs)) ;;; Keep this a separate function for testing. -(defun ensure-ctor (function-name class-name initargs) - (unless (fboundp function-name) - (make-ctor function-name class-name initargs))) +(defun ensure-ctor (function-name class-name initargs safe-code-p) + (with-world-lock () + (if (fboundp function-name) + (the ctor (fdefinition function-name)) + (make-ctor function-name class-name initargs safe-code-p)))) ;;; Keep this a separate function for testing. -(defun make-ctor (function-name class-name initargs) +(defun make-ctor (function-name class-name initargs safe-p) (without-package-locks ; for (setf symbol-function) - (let ((ctor (%make-ctor function-name class-name nil initargs))) - (push ctor *all-ctors*) - (setf (fdefinition function-name) ctor) - (install-initial-constructor ctor :force-p t) - ctor))) + (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p))) + (install-initial-constructor ctor :force-p t) + (push ctor *all-ctors*) + (setf (fdefinition function-name) ctor) + ctor))) + +;;; ***************** +;;; Inline CTOR cache +;;; ***************** +;;; +;;; The cache starts out as a list of CTORs, sorted with the most recently +;;; used CTORs near the head. If it expands too much, we switch to a vector +;;; with a simple hashing scheme. + +;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR +;;; is in the list but not one of the 4 first ones, return a new list with the +;;; found CTOR at the head. Thread-safe: the new list shares structure with +;;; the old, but is not desctructively modified. Returning the old list for +;;; hits close to the head reduces ping-ponging with multiple threads seeking +;;; the same list. +(defun find-ctor (key list) + (labels ((walk (tail from-head depth) + (declare (fixnum depth)) + (if tail + (let ((ctor (car tail))) + (if (eq (ctor-class-or-name ctor) key) + (if (> depth 3) + (values ctor + (nconc (list ctor) (nreverse from-head) (cdr tail))) + (values ctor + list)) + (walk (cdr tail) + (cons ctor from-head) + (logand #xf (1+ depth))))) + (values nil list)))) + (walk list nil 0))) + +(declaim (inline sxhash-symbol-or-class)) +(defun sxhash-symbol-or-class (x) + (cond ((symbolp x) (sxhash x)) + ((std-instance-p x) (std-instance-hash x)) + ((fsc-instance-p x) (fsc-instance-hash x)) + (t + (bug "Something strange where symbol or class expected.")))) + +;;; Max number of CTORs kept in an inline list cache. Once this is +;;; exceeded we switch to a table. +(defconstant +ctor-list-max-size+ 12) +;;; Max table size for CTOR cache. If the table fills up at this size +;;; we keep the same size and drop 50% of the old entries. +(defconstant +ctor-table-max-size+ (expt 2 8)) +;;; Even if there is space in the cache, if we cannot fit a new entry +;;; with max this number of collisions we expand the table (if possible) +;;; and rehash. +(defconstant +ctor-table-max-probe-depth+ 5) + +(defun make-ctor-table (size) + (declare (index size)) + (let ((real-size (power-of-two-ceiling size))) + (if (< real-size +ctor-table-max-size+) + (values (make-array real-size :initial-element nil) nil) + (values (make-array +ctor-table-max-size+ :initial-element nil) t)))) + +(declaim (inline mix-ctor-hash)) +(defun mix-ctor-hash (hash base) + (logand most-positive-fixnum (+ hash base 1))) + +(defun put-ctor (ctor table) + (cond ((try-put-ctor ctor table) + (values ctor table)) + (t + (expand-ctor-table ctor table)))) + +;;; Thread-safe: if two threads write to the same index in parallel, the other +;;; result is just lost. This is not an issue as the CTORs are used as their +;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other +;;; one is needed we just cache it again -- hopefully not getting stomped on +;;; that time. +(defun try-put-ctor (ctor table) + (declare (simple-vector table) (optimize speed)) + (let* ((class (ctor-class-or-name ctor)) + (base (sxhash-symbol-or-class class)) + (hash base) + (mask (1- (length table)))) + (declare (fixnum base hash mask)) + (loop repeat +ctor-table-max-probe-depth+ + do (let* ((index (logand mask hash)) + (old (aref table index))) + (cond ((and old (neq class (ctor-class-or-name old))) + (setf hash (mix-ctor-hash hash base))) + (t + (setf (aref table index) ctor) + (return-from try-put-ctor t))))) + ;; Didn't fit, must expand + nil)) + +(defun get-ctor (class table) + (declare (simple-vector table) (optimize speed)) + (let* ((base (sxhash-symbol-or-class class)) + (hash base) + (mask (1- (length table)))) + (declare (fixnum base hash mask)) + (loop repeat +ctor-table-max-probe-depth+ + do (let* ((index (logand mask hash)) + (old (aref table index))) + (if (and old (eq class (ctor-class-or-name old))) + (return-from get-ctor old) + (setf hash (mix-ctor-hash hash base))))) + ;; Nothing. + nil)) + +;;; Thread safe: the old table is read, but if another thread mutates +;;; it while we're reading we still get a sane result -- either the old +;;; or the new entry. The new table is locally allocated, so that's ok +;;; too. +(defun expand-ctor-table (ctor old) + (declare (simple-vector old)) + (let* ((old-size (length old)) + (new-size (* 2 old-size)) + (drop-random-entries nil)) + (tagbody + :again + (multiple-value-bind (new max-size-p) (make-ctor-table new-size) + (let ((action (if drop-random-entries + ;; Same logic as in method caches -- see comment + ;; there. + (randomly-punting-lambda (old-ctor) + (try-put-ctor old-ctor new)) + (lambda (old-ctor) + (unless (try-put-ctor old-ctor new) + (if max-size-p + (setf drop-random-entries t) + (setf new-size (* 2 new-size))) + (go :again)))))) + (aver (try-put-ctor ctor new)) + (dotimes (i old-size) + (let ((old-ctor (aref old i))) + (when old-ctor + (funcall action old-ctor)))) + (return-from expand-ctor-table (values ctor new))))))) + +(defun ctor-list-to-table (list) + (let ((table (make-ctor-table (length list)))) + (dolist (ctor list) + (setf table (nth-value 1 (put-ctor ctor table)))) + table)) +(defun ensure-cached-ctor (class-name store initargs safe-code-p) + (flet ((maybe-ctor-for-caching () + (if (typep class-name '(or symbol class)) + (let ((name (make-ctor-function-name class-name initargs safe-code-p))) + (ensure-ctor name class-name initargs safe-code-p)) + ;; Invalid first argument: let MAKE-INSTANCE worry about it. + (return-from ensure-cached-ctor + (values (lambda (&rest ctor-parameters) + (let (mi-initargs) + (doplist (key value) initargs + (push key mi-initargs) + (push (if (constantp value) + value + (pop ctor-parameters)) + mi-initargs)) + (apply #'make-instance class-name (nreverse mi-initargs)))) + store))))) + (if (listp store) + (multiple-value-bind (ctor list) (find-ctor class-name store) + (if ctor + (values ctor list) + (let ((ctor (maybe-ctor-for-caching))) + (if (< (length list) +ctor-list-max-size+) + (values ctor (cons ctor list)) + (values ctor (ctor-list-to-table list)))))) + (let ((ctor (get-ctor class-name store))) + (if ctor + (values ctor store) + (put-ctor (maybe-ctor-for-caching) store)))))) ;;; *********************************************** ;;; Compile-Time Expansion of MAKE-INSTANCE ******* ;;; *********************************************** -(define-compiler-macro make-instance (&whole form &rest args) +(defvar *compiling-optimized-constructor* nil) + +(define-compiler-macro make-instance (&whole form &rest args &environment env) (declare (ignore args)) - (or (make-instance->constructor-call form) + ;; Compiling an optimized constructor for a non-standard class means + ;; compiling a lambda with (MAKE-INSTANCE # ...) in it + ;; -- need to make sure we don't recurse there. + (or (unless *compiling-optimized-constructor* + (make-instance->constructor-call form (safe-code-p env))) form)) -(defun make-instance->constructor-call (form) - (destructuring-bind (fn class-name &rest args) form - (declare (ignore fn)) +(defun make-instance->constructor-call (form safe-code-p) + (destructuring-bind (class-arg &rest args) (cdr form) (flet (;; ;; Return the name of parameter number I of a constructor ;; function. @@ -172,60 +366,77 @@ (if (array-in-bounds-p ps i) (aref ps i) (format-symbol *pcl-package* ".P~D." i)))) - ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; Check if CLASS-ARG is a constant symbol. Give up if ;; not. - (check-class () - (unless (and class-name (constant-symbol-p class-name)) - (return-from make-instance->constructor-call nil))) + (constant-class-p () + (and class-arg (constant-class-arg-p class-arg))) ;; Check if ARGS are suitable for an optimized constructor. ;; Return NIL from the outer function if not. (check-args () (loop for (key . more) on args by #'cddr do - (when (or (null more) - (not (constant-symbol-p key)) - (eq :allow-other-keys (eval key))) - (return-from make-instance->constructor-call nil))))) - (check-class) + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (constant-form-value key))) + (return-from make-instance->constructor-call nil))))) (check-args) ;; Collect a plist of initargs and constant values/parameter names ;; in INITARGS. Collect non-constant initialization forms in ;; VALUE-FORMS. (multiple-value-bind (initargs value-forms) (loop for (key value) on args by #'cddr and i from 0 - collect (eval key) into initargs + collect (constant-form-value key) into initargs if (constantp value) - collect value into initargs + collect value into initargs else - collect (parameter-name i) into initargs - and collect value into value-forms + collect (parameter-name i) into initargs + and collect value into value-forms finally - (return (values initargs value-forms))) - (let* ((class-name (eval class-name)) - (function-name (make-ctor-function-name class-name initargs))) - ;; Prevent compiler warnings for calling the ctor. - (proclaim-as-fun-name function-name) - (note-name-defined function-name :function) - (when (eq (info :function :where-from function-name) :assumed) - (setf (info :function :where-from function-name) :defined) - (when (info :function :assumed-type function-name) - (setf (info :function :assumed-type function-name) nil))) - ;; Return code constructing a ctor at load time, which, when - ;; called, will set its funcallable instance function to an - ;; optimized constructor function. - `(locally - (declare (disable-package-locks ,function-name)) - (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) - (declare (ignore .x.)) - ;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (funcall (function ,function-name) ,@value-forms)))))))) - + (return (values initargs value-forms))) + (if (constant-class-p) + (let* ((class-or-name (constant-form-value class-arg)) + (function-name (make-ctor-function-name class-or-name initargs + safe-code-p))) + ;; Prevent compiler warnings for calling the ctor. + (proclaim-as-fun-name function-name) + (note-name-defined function-name :function) + (when (eq (info :function :where-from function-name) :assumed) + (setf (info :function :where-from function-name) :defined) + (when (info :function :assumed-type function-name) + (setf (info :function :assumed-type function-name) nil))) + ;; Return code constructing a ctor at load time, which, + ;; when called, will set its funcallable instance + ;; function to an optimized constructor function. + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-or-name ',initargs + ',safe-code-p)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (funcall (function ,function-name) ,@value-forms)))) + (when (and class-arg (not (constantp class-arg))) + ;; Build an inline cache: a CONS, with the actual cache + ;; in the CDR. + `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun. + make-instance)) + (let* ((.cache. (load-time-value (cons 'ctor-cache nil))) + (.store. (cdr .cache.)) + (.class-arg. ,class-arg)) + (multiple-value-bind (.fun. .new-store.) + (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p) + ;; Thread safe: if multiple threads hit this in + ;; parallel, the update from the other one is + ;; just lost -- no harm done, except for the need + ;; to redo the work next time. + (unless (eq .store. .new-store.) + (setf (cdr .cache.) .new-store.)) + (funcall (truly-the function .fun.) ,@value-forms)))))))))) ;;; ************************************************** ;;; Load-Time Constructor Function Generation ******* @@ -239,21 +450,31 @@ (defvar *the-system-si-method* nil) (defun install-optimized-constructor (ctor) - (let ((class (find-class (ctor-class-name ctor)))) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (setf (ctor-class ctor) class) - (pushnew ctor (plist-value class 'ctors)) - (setf (funcallable-instance-fun ctor) - ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL - ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't - ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA - ;; expressions. The below should be equivalent, since we - ;; have a compiler-only implementation. - ;; - ;; (except maybe for optimization qualities? -- CSR, - ;; 2004-07-12) - (eval `(function ,(constructor-function-form ctor)))))) + (with-world-lock () + (let* ((class-or-name (ctor-class-or-name ctor)) + (class (if (symbolp class-or-name) + (find-class class-or-name) + class-or-name))) + (unless (class-finalized-p class) + (finalize-inheritance class)) + ;; We can have a class with an invalid layout here. Such a class + ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE + ;; ...), because part of the deal is that those only happen from + ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the + ;; class. An invalid layout of T needs to be flushed, however. + (when (eq (layout-invalid (class-wrapper class)) t) + (%force-cache-flushes class)) + (setf (ctor-class ctor) class) + (pushnew ctor (plist-value class 'ctors) :test #'eq) + (multiple-value-bind (form locations names optimizedp) + (constructor-function-form ctor) + (setf (funcallable-instance-fun ctor) + (apply + (let ((*compiling-optimized-constructor* t)) + (handler-bind ((compiler-note #'muffle-warning)) + (compile nil `(lambda ,names ,form)))) + locations) + (ctor-state ctor) (if optimizedp 'optimized 'fallback)))))) (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) @@ -306,40 +527,47 @@ ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. - (or (and (not (structure-class-p class)) - (not (condition-class-p class)) - (null (cdr make-instance-methods)) - (null (cdr allocate-instance-methods)) - (every (lambda (x) - (member (slot-definition-allocation x) - '(:instance :class))) - (class-slots class)) - (null (check-initargs-1 - class - (append - (ctor-default-initkeys - (ctor-initargs ctor) (class-default-initargs class)) - (plist-keys (ctor-initargs ctor))) - (append ii-methods si-methods) nil nil)) - (not (around-or-nonstandard-primary-method-p - ii-methods *the-system-ii-method*)) - (not (around-or-nonstandard-primary-method-p - si-methods *the-system-si-method*)) - ;; the instance structure protocol goes through - ;; slot-value(-using-class) and friends (actually just - ;; (SETF SLOT-VALUE-USING-CLASS) and - ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard - ;; applicable methods we can't shortcircuit them. - (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) - (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) - (optimizing-generator ctor ii-methods si-methods)) - (fallback-generator ctor ii-methods si-methods)))) + (let ((maybe-invalid-initargs + (check-initargs-1 + class + (append + (ctor-default-initkeys + (ctor-initargs ctor) (class-default-initargs class)) + (plist-keys (ctor-initargs ctor))) + (append ii-methods si-methods) nil nil)) + (custom-make-instance + (not (null (cdr make-instance-methods))))) + (if (and (not (structure-class-p class)) + (not (condition-class-p class)) + (not custom-make-instance) + (null (cdr allocate-instance-methods)) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class)) + (not maybe-invalid-initargs) + (not (around-or-nonstandard-primary-method-p + ii-methods *the-system-ii-method*)) + (not (around-or-nonstandard-primary-method-p + si-methods *the-system-si-method*)) + ;; the instance structure protocol goes through + ;; slot-value(-using-class) and friends (actually just + ;; (SETF SLOT-VALUE-USING-CLASS) and + ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard + ;; applicable methods we can't shortcircuit them. + (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods)) + (optimizing-generator ctor ii-methods si-methods) + (fallback-generator ctor ii-methods si-methods + (or maybe-invalid-initargs custom-make-instance)))))) (defun around-or-nonstandard-primary-method-p (methods &optional standard-method) (loop with primary-checked-p = nil for method in methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) when (or (eq :around (car qualifiers)) (and (null qualifiers) (not primary-checked-p) @@ -349,22 +577,50 @@ when (null qualifiers) do (setq primary-checked-p t))) -(defun fallback-generator (ctor ii-methods si-methods) +(defun fallback-generator (ctor ii-methods si-methods use-make-instance) (declare (ignore ii-methods si-methods)) - `(instance-lambda ,(make-ctor-parameter-list ctor) - ;; The CTOR MAKE-INSTANCE optimization only kicks in when the - ;; first argument to MAKE-INSTANCE is a constant symbol: by - ;; calling it with a class, as here, we inhibit the optimization, - ;; so removing the possibility of endless recursion. -- CSR, - ;; 2004-07-12 - (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))) + (let ((class (ctor-class ctor)) + (lambda-list (make-ctor-parameter-list ctor)) + (initargs (quote-plist-keys (ctor-initargs ctor)))) + (if use-make-instance + `(lambda ,lambda-list + (declare #.*optimize-speed*) + ;; The CTOR MAKE-INSTANCE optimization checks for + ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around + ;; compilation of the constructor, hence avoiding the + ;; possibility of endless recursion. + (make-instance ,class ,@initargs)) + (let ((defaults (class-default-initargs class))) + (when defaults + (setf initargs (ctor-default-initargs initargs defaults))) + `(lambda ,lambda-list + (declare #.*optimize-speed*) + (fast-make-instance ,class ,@initargs)))))) + +;;; Not as good as the real optimizing generator, but faster than going +;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs. +(defun fast-make-instance (class &rest initargs) + (declare #.*optimize-speed*) + (declare (dynamic-extent initargs)) + (let ((.instance. (apply #'allocate-instance class initargs))) + (apply #'initialize-instance .instance. initargs) + .instance.)) (defun optimizing-generator (ctor ii-methods si-methods) - (multiple-value-bind (body before-method-p) + (multiple-value-bind (locations names body before-method-p) (fake-initialization-emf ctor ii-methods si-methods) - `(instance-lambda ,(make-ctor-parameter-list ctor) - (declare #.*optimize-speed*) - ,(wrap-in-allocate-forms ctor body before-method-p)))) + (let ((wrapper (class-wrapper (ctor-class ctor)))) + (values + `(lambda ,(make-ctor-parameter-list ctor) + (declare #.*optimize-speed*) + (block nil + (when (layout-invalid ,wrapper) + (install-initial-constructor ,ctor) + (return (funcall ,ctor ,@(make-ctor-parameter-list ctor)))) + ,(wrap-in-allocate-forms ctor body before-method-p))) + locations + names + t)))) ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run @@ -390,6 +646,7 @@ .instance.) `(let* ((.instance. (,allocation-function ,wrapper)) (.slots. (,slots-fetcher .instance.))) + (declare (ignorable .slots.)) ,body .instance.)))) @@ -413,9 +670,11 @@ (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) (let ((initargs (ctor-initargs ctor))) - (multiple-value-bind (bindings vars defaulting-initargs body) + (multiple-value-bind (locations names bindings vars defaulting-initargs body) (slot-init-forms ctor (or ii-before si-before)) (values + locations + names `(let ,bindings (declare (ignorable ,@vars)) (let (,@(when (or ii-before ii-after) @@ -441,7 +700,9 @@ ;;; must be called. (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) if (null qualifiers) collect method into primary else if (eq :around (car qualifiers)) @@ -453,6 +714,15 @@ finally (return (values around before (first primary) (reverse after))))) +(defmacro with-type-checked ((type safe-p) &body body) + (if safe-p + ;; To handle FUNCTION types reasonable, we use SAFETY 3 and + ;; THE instead of e.g. CHECK-TYPE. + `(locally + (declare (optimize (safety 3))) + (the ,type (progn ,@body))) + `(progn ,@body))) + ;;; Return as multiple values bindings for default initialization ;;; arguments, variable names, defaulting initargs and a body for ;;; initializing instance and class slots of an object costructed by @@ -465,6 +735,7 @@ (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) (initkeys (plist-keys initargs)) + (safe-p (ctor-safe-p ctor)) (slot-vector (make-array (layout-length (class-wrapper class)) :initial-element nil)) @@ -484,32 +755,33 @@ ((integerp location) (not (null (aref slot-vector location)))) (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) + (class-init (location kind val type) (aver (consp location)) (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) + (push (list location kind val type) class-inits))) + (instance-init (location kind val type) (aver (integerp location)) (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) + (setf (aref slot-vector location) (list kind val type)))) (default-init-var-name (i) (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) (aref ps i) - (format-symbol *pcl-package* ".D~D." i))))) + (format-symbol *pcl-package* ".D~D." i)))) + (location-var-name (i) + (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.))) + (if (array-in-bounds-p ls i) + (aref ls i) + (format-symbol *pcl-package* ".L~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as kind = (if (constantp value) 'constant 'param) + as locations = (initarg-locations key) + do (loop for (location . type) in locations + do (if (consp location) + (class-init location kind value type) + (instance-init location kind value type)))) ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied @@ -517,28 +789,29 @@ ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. (loop for (key initform initfn) in default-initargs and i from 0 - unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (ecase type - (constant - (push key defaulting-initargs) - (push initform defaulting-initargs)) - (var - (push key defaulting-initargs) - (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) + unless (member key initkeys :test #'eq) + do (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind + (constant + (push (list 'quote key) defaulting-initargs) + (push initform defaulting-initargs)) + (var + (push (list 'quote key) defaulting-initargs) + (push (default-init-var-name i) defaulting-initargs))) + (when (eq kind 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (loop for (location . type) in (initarg-locations key) + do (if (consp location) + (class-init location kind init type) + (instance-init location kind init type))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) as location = (slot-definition-location slotd) + as type = (slot-definition-type slotd) as allocation = (slot-definition-allocation slotd) as initfn = (slot-definition-initfunction slotd) as initform = (slot-definition-initform slotd) do @@ -546,63 +819,89 @@ (null initfn) (initializedp location)) (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + (instance-init location 'initform initform type) + (instance-init location 'initform/initfn initfn type)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type + as (kind value type) = slot-entry collect + (ecase kind ((nil) (unless before-method-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + ,value))) (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) (initform/initfn (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) + (with-type-checked (,type ,safe-p) + (funcall ,value))))) (initform (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - ',(eval value))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))) `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value))))) (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value)))))) - (class-init-forms - (loop for (location type value) in class-inits collect - `(setf (cdr ',location) - ,(ecase type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value))))))) - (multiple-value-bind (vars bindings) - (loop for (var . initfn) in (nreverse default-inits) - collect var into vars - collect `(,var (funcall ,initfn)) into bindings - finally (return (values vars bindings))) - (values bindings vars (nreverse defaulting-initargs) - `(,@(delete nil instance-init-forms) - ,@class-init-forms))))))) - -;;; Return an alist of lists (KEY LOCATION ...) telling, for each -;;; key in INITKEYS, which locations the initarg initializes. -;;; CLASS is the class of the instance being initialized. + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))))))) + ;; we are not allowed to modify QUOTEd locations, so we can't + ;; generate code like (setf (cdr ',location) arg). Instead, + ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to + ;; be bound to the location. + (multiple-value-bind (names locations class-init-forms) + (loop for (location kind value type) in class-inits + for i upfrom 0 + for name = (location-var-name i) + collect name into names + collect location into locations + collect `(setf (cdr ,name) + (with-type-checked (,type ,safe-p) + ,(case kind + (constant `',(constant-form-value value)) + ((param var) `,value) + (initfn `(funcall ,value))))) + into class-init-forms + finally (return (values names locations class-init-forms))) + (multiple-value-bind (vars bindings) + (loop for (var . initfn) in (nreverse default-inits) + collect var into vars + collect `(,var (funcall ,initfn)) into bindings + finally (return (values vars bindings))) + (values locations names + bindings vars + (nreverse defaulting-initargs) + `(,@(delete nil instance-init-forms) + ,@class-init-forms)))))))) + +;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...) +;;; telling, for each key in INITKEYS, which locations the initarg +;;; initializes and the associated type with the location. CLASS is +;;; the class of the instance being initialized. (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) for key in initkeys collect (loop for slot in slots if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations + collect (cons (slot-definition-location slot) + (slot-definition-type slot)) + into locations else collect slot into remaining-slots finally @@ -615,14 +914,15 @@ ;;; ******************************* (defun update-ctors (reason &key class name generic-function method) - (labels ((reset (class &optional ri-cache-p (ctorsp t)) + (labels ((reset (class &optional initarg-caches-p (ctorsp t)) (when ctorsp (dolist (ctor (plist-value class 'ctors)) (install-initial-constructor ctor))) - (when ri-cache-p - (setf (plist-value class 'ri-initargs) ())) + (when initarg-caches-p + (dolist (cache '(mi-initargs ri-initargs)) + (setf (plist-value class cache) ()))) (dolist (subclass (class-direct-subclasses class)) - (reset subclass ri-cache-p ctorsp)))) + (reset subclass initarg-caches-p ctorsp)))) (ecase reason ;; CLASS must have been specified. (finalize-inheritance @@ -630,7 +930,7 @@ ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* - when (eq (ctor-class-name ctor) name) do + when (eq (ctor-class-or-name ctor) name) do (when (ctor-class ctor) (reset (ctor-class ctor))) (loop-finish))) @@ -639,8 +939,16 @@ (flet ((class-of-1st-method-param (method) (type-class (first (method-specializers method))))) (case (generic-function-name generic-function) - ((make-instance allocate-instance - initialize-instance shared-initialize) + ((make-instance allocate-instance) + ;; FIXME: I can't see a way of working out which classes a + ;; given metaclass specializer are applicable to short of + ;; iterating and testing with class-of. It would be good + ;; to not invalidate caches of system classes at this + ;; point (where it is not legal to define a method + ;; applicable to them on system functions). -- CSR, + ;; 2010-07-13 + (reset (find-class 'standard-object) t t)) + ((initialize-instance shared-initialize) (reset (class-of-1st-method-param method) t t)) ((reinitialize-instance) (reset (class-of-1st-method-param method) t nil)) @@ -656,15 +964,61 @@ (defun precompile-ctors () (dolist (ctor *all-ctors*) (when (null (ctor-class ctor)) - (let ((class (find-class (ctor-class-name ctor) nil))) + (let ((class (find-class (ctor-class-or-name ctor) nil))) (when (and class (class-finalized-p class)) (install-optimized-constructor ctor)))))) +(defun maybe-call-ctor (class initargs) + (flet ((frob-initargs (ctor) + (do ((ctail (ctor-initargs ctor)) + (itail initargs) + (args nil)) + ((or (null ctail) (null itail)) + (values (nreverse args) (and (null ctail) (null itail)))) + (unless (eq (pop ctail) (pop itail)) + (return nil)) + (let ((cval (pop ctail)) + (ival (pop itail))) + (if (constantp cval) + (unless (eql cval ival) + (return nil)) + (push ival args)))))) + (dolist (ctor (plist-value class 'ctors)) + (when (eq (ctor-state ctor) 'optimized) + (multiple-value-bind (ctor-args matchp) + (frob-initargs ctor) + (when matchp + (return (apply ctor ctor-args)))))))) + +;;; FIXME: CHECK-FOO-INITARGS share most of their bodies. +(defun check-mi-initargs (class initargs) + (let* ((class-proto (class-prototype class)) + (keys (plist-keys initargs)) + (cache (plist-value class 'mi-initargs)) + (cached (assoc keys cache :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid + (check-initargs-1 + class initargs + (list (list* 'allocate-instance class initargs) + (list* 'initialize-instance class-proto initargs) + (list* 'shared-initialize class-proto t initargs)) + t nil))) + (setf (plist-value class 'mi-initargs) + (acons keys invalid cache)) + invalid)))) + (when invalid-keys + ;; FIXME: should have an operation here, and maybe a set of + ;; valid keys. + (error 'initarg-error :class class :initargs invalid-keys)))) + (defun check-ri-initargs (instance initargs) (let* ((class (class-of instance)) (keys (plist-keys initargs)) - (cached (assoc keys (plist-value class 'ri-initargs) - :test #'equal)) + (cache (plist-value class 'ri-initargs)) + (cached (assoc keys cache :test #'equal)) (invalid-keys (if (consp cached) (cdr cached) @@ -678,7 +1032,7 @@ (list* 'shared-initialize instance nil initargs)) t nil))) (setf (plist-value class 'ri-initargs) - (acons keys invalid cached)) + (acons keys invalid cache)) invalid)))) (when invalid-keys (error 'initarg-error :class class :initargs invalid-keys))))