(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))))
\f
;;; *****************
;;; CTORS *********
;;; funcallable instance is set to it.
;;;
(!defstruct-with-alternate-metaclass ctor
- :slot-names (function-name class-or-name class initargs safe-p)
+ :slot-names (function-name class-or-name class initargs state safe-p)
:boa-constructor %make-ctor
:superclass-name function
:metaclass-name static-classoid
;;; optimized constructor function when called.
(defun install-initial-constructor (ctor &key force-p)
(when (or force-p (ctor-class ctor))
- (let ((*installing-ctor* t))
- (setf (ctor-class ctor) nil)
- (setf (funcallable-instance-fun ctor)
- #'(lambda (&rest args)
- (install-optimized-constructor ctor)
- (apply ctor args)))
- (setf (%funcallable-instance-info ctor 1)
- (ctor-function-name ctor)))))
+ (setf (ctor-class ctor) nil
+ (ctor-state ctor) 'initial)
+ (setf (funcallable-instance-fun ctor)
+ #'(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 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 safe-code-p)
- (unless (fboundp function-name)
- (make-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 safe-p)
(without-package-locks ; for (setf symbol-function)
- (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
- (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)))
\f
;;; *****************
;;; Inline CTOR cache
(setf table (nth-value 1 (put-ctor ctor table))))
table))
-(defun ctor-for-caching (class-name initargs safe-code-p)
- (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
- (or (ensure-ctor name class-name initargs safe-code-p)
- (fdefinition name))))
-
(defun ensure-cached-ctor (class-name store initargs safe-code-p)
- (if (listp store)
- (multiple-value-bind (ctor list) (find-ctor class-name store)
- (if ctor
- (values ctor list)
- (let ((ctor (ctor-for-caching class-name initargs safe-code-p)))
- (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 (ctor-for-caching class-name initargs safe-code-p)
- store)))))
+ (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))))))
\f
;;; ***********************************************
;;; Compile-Time Expansion of MAKE-INSTANCE *******
(define-compiler-macro make-instance (&whole form &rest args &environment env)
(declare (ignore args))
- ;; Compiling an optimized constructor for a non-standard class means compiling a
- ;; lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it -- need
- ;; to make sure we don't recurse there.
+ ;; Compiling an optimized constructor for a non-standard class means
+ ;; compiling a lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) 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))
(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.
+ ;; 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
(function (&rest t) t))
,function-name))
(funcall (function ,function-name) ,@value-forms))))
- (when class-arg
- ;; Build an inline cache: a CONS, with the actual cache in the CDR.
+ (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)))
(.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 paralle, the update
- ;; from the other one is just lost -- no harm done, except for the
- ;; need to redo the work next time.
+ ;; 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))))))))))
(%force-cache-flushes class))
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors) :test #'eq)
- (setf (funcallable-instance-fun ctor)
- (multiple-value-bind (form locations names)
- (constructor-function-form ctor)
+ (multiple-value-bind (form locations names optimizedp)
+ (constructor-function-form ctor)
+ (setf (funcallable-instance-fun ctor)
(apply
(let ((*compiling-optimized-constructor* t))
- (compile nil `(lambda ,names ,form)))
- locations))))))
+ (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))
;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
;; together with the system-defined ones in what
;; COMPUTE-APPLICABLE-METHODS returns.
- (if (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)
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))
- `(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)
- ,@(quote-plist-keys (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 (locations names body before-method-p)
(return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
,(wrap-in-allocate-forms ctor body before-method-p)))
locations
- names))))
+ names
+ t))))
;;; Return a form wrapped around BODY that allocates an instance
;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
;;; *******************************
(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
(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))
(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)
(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))))
projects / sbcl.git / blobdiff