From: Christophe Rhodes Date: Sat, 16 Feb 2008 10:34:45 +0000 (+0000) Subject: 1.0.14.30: don't construct obsolete instances X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a6bd77d792d22785860bd082d55692f4a1c65fd7;p=sbcl.git 1.0.14.30: don't construct obsolete instances The CTOR make-instance optimization machinery closes over the class wrapper of the class in question; however, there are code paths that cause wrappers to be invalidated without causing all constructors to be recomputed: for instance, the redefinition of a superclass, or calling MAKE-INSTANCES-OBSOLETE. This would mean that the CTORs would create obsolete instances, which would instantly trap, showing up as slowness in CLOS-heavy code. Problem and fix largely identified by Andy Hefner in . --- diff --git a/NEWS b/NEWS index 2106520..bec35f1 100644 --- a/NEWS +++ b/NEWS @@ -14,7 +14,7 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14: * bug fix: on x86 and x86-64 pointer based EQ-hashing now uses the full address of the object, and none of the tag bits. * bug fix: readably printing hash-tables now respects other printer - control variables. (reported by Cedric St-Jean) + control variables. (reported by Cedric St-Jean) * bug fix: compiler gave a bogus STYLE-WARNING for the :SYNCHRONIZED keyword with MAKE-HASH-TABLE. * bug fix: export SB-POSIX:MKSTEMP. @@ -23,7 +23,10 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14: well. * bug fix: MAKE-INSTANCE optimizations interacted badly with non-keyword :DEFAULT-INITARGS in the presence of :BEFORE/:AFTER - methods on SHARED-INITIALIZE. (thanks to Matt Marjanovic) + methods on SHARED-INITIALIZE. (thanks to Matt Marjanovic) + * bug fix: the CTOR optimization for MAKE-INSTANCE should no longer + create obsolete instances in the case of redefinition or + obsoletion of a superclass. (thanks to Andy Hefner) changes in sbcl-1.0.14 relative to sbcl-1.0.13: * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 0bd3973..9baa699 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -244,6 +244,13 @@ (let ((class (find-class (ctor-class-name ctor)))) (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)) (setf (funcallable-instance-fun ctor) @@ -359,12 +366,17 @@ (defun optimizing-generator (ctor ii-methods si-methods) (multiple-value-bind (locations names body before-method-p) (fake-initialization-emf ctor ii-methods si-methods) - (values - `(lambda ,(make-ctor-parameter-list ctor) - (declare #.*optimize-speed*) - ,(wrap-in-allocate-forms ctor body before-method-p)) - locations - names))) + (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)))) ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp new file mode 100644 index 0000000..e8fecb1 --- /dev/null +++ b/tests/ctor.impure.lisp @@ -0,0 +1,87 @@ +;;;; gray-box testing of the constructor optimization machinery + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(defpackage "CTOR-TEST" + (:use "CL")) + +(in-package "CTOR-TEST") + +(defclass no-slots () ()) + +(defun make-no-slots () + (make-instance 'no-slots)) +(compile 'make-no-slots) + +(defmethod update-instance-for-redefined-class + ((object no-slots) added discarded plist &rest initargs) + (declare (ignore initargs)) + (error "Called U-I-F-R-C on ~A" object)) + +(assert (typep (make-no-slots) 'no-slots)) + +(make-instances-obsolete 'no-slots) + +(assert (typep (make-no-slots) 'no-slots)) +(assert (typep (funcall #'(sb-pcl::ctor no-slots nil)) 'no-slots)) + +(defclass one-slot () + ((a :initarg :a))) + +(defun make-one-slot-a (a) + (make-instance 'one-slot :a a)) +(compile 'make-one-slot-a) +(defun make-one-slot-noa () + (make-instance 'one-slot)) +(compile 'make-one-slot-noa) + +(defmethod update-instance-for-redefined-class + ((object one-slot) added discarded plist &rest initargs) + (declare (ignore initargs)) + (error "Called U-I-F-R-C on ~A" object)) + +(assert (= (slot-value (make-one-slot-a 3) 'a) 3)) +(assert (not (slot-boundp (make-one-slot-noa) 'a))) + +(make-instances-obsolete 'one-slot) + +(assert (= (slot-value (make-one-slot-a 3) 'a) 3)) +(assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) 4) 'a) 4)) +(assert (not (slot-boundp (make-one-slot-noa) 'a))) +(assert (not (slot-boundp (funcall #'(sb-pcl::ctor one-slot nil)) 'a))) + +(defclass one-slot-superclass () + ((b :initarg :b))) +(defclass one-slot-subclass (one-slot-superclass) + ()) + +(defun make-one-slot-subclass (b) + (make-instance 'one-slot-subclass :b b)) +(compile 'make-one-slot-subclass) + +(defmethod update-instance-for-redifined-class + ((object one-slot-superclass) added discarded plist &rest initargs) + (declare (ignore initargs)) + (error "Called U-I-F-R-C on ~A" object)) + +(assert (= (slot-value (make-one-slot-subclass 2) 'b) 2)) + +(make-instances-obsolete 'one-slot-subclass) + +(assert (= (slot-value (make-one-slot-subclass 2) 'b) 2)) +(assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 3) 'b) 3)) +(make-instances-obsolete 'one-slot-superclass) + +(assert (= (slot-value (make-one-slot-subclass 2) 'b) 2)) +(assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4)) + +;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 1664fa2..17553c4 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.14.29" +"1.0.14.30"