X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fctor.lisp;h=658414241bbe6f7ffbf8bec442b5839992630e79;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=26b64e24af44c6ddf826c25f194ac62331a48812;hpb=95d19447c10434753c2168ac943152fd5e3ded3d;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 26b64e2..6584142 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -97,12 +97,22 @@ (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 ********* @@ -132,31 +142,32 @@ ;;; 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) + (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 safe-p))) + (install-initial-constructor ctor :force-p t) + (push ctor *all-ctors*) + (setf (fdefinition function-name) ctor) + ctor))) ;;; ***************** ;;; Inline CTOR cache @@ -299,25 +310,35 @@ (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)))))) ;;; *********************************************** ;;; Compile-Time Expansion of MAKE-INSTANCE ******* @@ -398,7 +419,7 @@ (function (&rest t) t)) ,function-name)) (funcall (function ,function-name) ,@value-forms)))) - (when class-arg + (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)) @@ -447,7 +468,8 @@ (constructor-function-form ctor) (apply (let ((*compiling-optimized-constructor* t)) - (compile nil `(lambda ,names ,form))) + (handler-bind ((compiler-note #'muffle-warning)) + (compile nil `(lambda ,names ,form)))) locations)))))) (defun constructor-function-form (ctor) @@ -501,34 +523,39 @@ ;; 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) @@ -546,16 +573,33 @@ 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)