From c4a60e6a7fd0381f97a88e28b3778d4352ec4259 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 1 Jul 2009 15:13:09 +0000 Subject: [PATCH] 1.0.29.54.rc2: two more CTOR optimization issues * Invalid calls of the form (MAKE-INSTANCE ''QUUX) or similar reported hard to understand errors instead of using the NO-APPLICABLE-METHOD machinery. (reported by Gabor Melis) * Runtime generation of new CTORs for the inline cache was not thread safe: grab *WORLD-LOCK* to ansure that (1) all CTORs end up in *ALL-CTORS* (2) we don't construct a CTOR with the same name twice. Also initialize the new CTOR with the initial constructor before setting its FDEFINITION: this is strictly speaking not needed given the lock, but more clearly correct. No test-case, as I was unable to actually provoke problem in real code. --- NEWS | 2 +- src/pcl/ctor.lisp | 64 ++++++++++++++++++++++++++++-------------------- tests/ctor.impure.lisp | 20 +++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 60 insertions(+), 28 deletions(-) diff --git a/NEWS b/NEWS index 4481e43..e50aaa2 100644 --- a/NEWS +++ b/NEWS @@ -63,7 +63,7 @@ changes in sbcl-1.0.29.54.rc1 relative to sbcl-1.0.29: * bug fix: bogus undefined variable warnings from fopcompiled references to global variables. (thanks to Lars Rune Nøstdal) * bug fix: foreign function names should now appear in backtraces on - FC6 as well. (reported by Tomasz Skutnik and obias Rautenkranz) + FC6 as well. (reported by Tomasz Skutnik and Tobias Rautenkranz) * bug fix: SETF compiler macro documentation strings are not discarded anymore. * bug fix: GENTEMP is now unaffected by pretty printer dispatch table. diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 04daadf..6584142 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -155,17 +155,19 @@ ;;; 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 @@ -308,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 ******* @@ -407,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)) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index 08a41c6..12c1f89 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -217,5 +217,25 @@ (handler-bind ((sb-ext:compiler-note #'error)) (funcall fun 41) (funcall fun 13)))) + +;;; NO-APPLICABLE-METHOD called +(defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args) + (cons :no-applicable-method args)) +(with-test (:name :constant-invalid-class-arg) + (assert (equal + '(:no-applicable-method "FOO" :quux 14) + (funcall (compile nil `(lambda (x) (make-instance "FOO" :quux x))) 14))) + (assert (equal + '(:no-applicable-method 'abc zot 1 bar 2) + (funcall (compile nil `(lambda (x y) (make-instance ''abc 'zot x 'bar y))) + 1 2)))) +(with-test (:name :variable-invalid-class-arg) + (assert (equal + '(:no-applicable-method "FOO" :quux 14) + (funcall (compile nil `(lambda (c x) (make-instance c :quux x))) "FOO" 14))) + (assert (equal + '(:no-applicable-method 'abc zot 1 bar 2) + (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y))) + ''abc 1 2)))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index b633a15..d204c3c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.54.rc1" +"1.0.29.54.rc2" -- 1.7.10.4