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
	<http://paste.lisp.org/display/55689>.

diff --git a/NEWS b/NEWS
index 2106520..bec35f1 100644 (file)
--- 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 (file)
--- 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 (file)
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")
+\f
+(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))
+\f
+(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)))
+\f
+(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))
+\f
+;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 1664fa2..17553c4 100644 (file)
--- 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"