From 14c8e1a7d219eaccf6657b3fa3f24de9a24717cb Mon Sep 17 00:00:00 2001 From: Richard M Kreuter Date: Tue, 23 Sep 2008 20:05:44 +0000 Subject: [PATCH] 1.0.20.25: Produce a loadable FASL when compiling an incompatible DEFSTRUCT. * Add some tests to see that redefining a STRUCTURE-CLASS works as one might expect, and that compiling a file whose loading redefines a STRUCTURE-CLASS works, too. * There are some nasty intermediate states having to do with subclasses defined in separate files (some are described in the tests), but that's not actually new. --- src/code/class.lisp | 5 +- src/code/defstruct.lisp | 90 +++++++------ tests/defstruct.impure.lisp | 297 +++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 352 insertions(+), 42 deletions(-) diff --git a/src/code/class.lisp b/src/code/class.lisp index abe8d0e..6639a3a 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -367,7 +367,7 @@ (when diff (warn "in class ~S:~% ~ - ~:(~A~) definition of superclass ~S is incompatible with~% ~ + ~@(~A~) definition of superclass ~S is incompatible with~% ~ ~A definition." name old-context @@ -421,8 +421,7 @@ ;; priority. (3) We now have the ability to rebuild the SBCL ;; system from scratch, so we no longer need this functionality in ;; order to maintain the SBCL system by modifying running images. - (error "The class ~S was not changed, and there's no guarantee that~@ - the loaded code (which expected another layout) will work." + (error "The loaded code expects an incompatible layout for class ~S." (layout-proper-name layout))) (values)) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index aac8f2d..dc18208 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -912,13 +912,13 @@ (unless (eq (classoid-layout classoid) layout) (register-layout layout))) (t + (%redefine-defstruct classoid old-layout layout) (let ((old-dd (layout-info old-layout))) (when (defstruct-description-p old-dd) (dolist (slot (dd-slots old-dd)) (fmakunbound (dsd-accessor-name slot)) (unless (dsd-read-only slot) (fmakunbound `(setf ,(dsd-accessor-name slot))))))) - (%redefine-defstruct classoid old-layout layout) (setq layout (classoid-layout classoid)))) (setf (find-classoid (dd-name dd)) classoid) @@ -1000,23 +1000,59 @@ (info :type :compiler-layout (dd-name dd)) (ensure-structure-class dd inherits - (if clayout-p "previously compiled" "current") - "compiled" + (if clayout-p + "The most recently compiled" + "The current") + "the most recently loaded" :compiler-layout clayout)) (cond (old-layout - (undefine-structure (layout-classoid old-layout)) - (when (and (classoid-subclasses classoid) - (not (eq layout old-layout))) - (collect ((subs)) - (dohash ((classoid layout) (classoid-subclasses classoid) - :locked t) - (declare (ignore layout)) - (undefine-structure classoid) - (subs (classoid-proper-name classoid))) - (when (subs) - (warn "removing old subclasses of ~S:~% ~S" - (classoid-name classoid) - (subs)))))) + (labels + ;; Blow away all the compiler info for the structure + ;; CLASS. Iterate over this type, clearing the compiler + ;; structure type info, and undefining all the + ;; associated functions. FIXME: maybe rename + ;; UNDEFINE-FUN-NAME to UNDECLARE-FUNCTION-NAME? + ((undeclare-structure (classoid subclasses-p) + (let ((info (layout-info (classoid-layout classoid)))) + (when (defstruct-description-p info) + (let ((type (dd-name info))) + (remhash type *typecheckfuns*) + (setf (info :type :compiler-layout type) nil) + (undefine-fun-name (dd-copier-name info)) + (undefine-fun-name (dd-predicate-name info)) + (dolist (slot (dd-slots info)) + (let ((fun (dsd-accessor-name slot))) + (unless (accessor-inherited-data fun info) + (undefine-fun-name fun) + (unless (dsd-read-only slot) + (undefine-fun-name `(setf ,fun))))))) + ;; Clear out the SPECIFIER-TYPE cache so that subsequent + ;; references are unknown types. + (values-specifier-type-cache-clear))) + (when subclasses-p + (collect ((subs)) + (dohash ((classoid layout) + (classoid-subclasses classoid) + :locked t) + (declare (ignore layout)) + (undeclare-structure classoid nil) + (subs (classoid-proper-name classoid))) + ;; Is it really necessary to warn about + ;; undeclaring functions for subclasses? + (when (subs) + (warn "undeclaring functions for old subclasses ~ + of ~S:~% ~S" + (classoid-name classoid) + (subs))))))) + (undeclare-structure (layout-classoid old-layout) + (and (classoid-subclasses classoid) + (not (eq layout old-layout)))) + (setf (layout-invalid layout) nil) + ;; FIXME: it might be polite to hold onto old-layout and + ;; restore it at the end of the file. -- RMK 2008-09-19 + ;; (International Talk Like a Pirate Day). + (warn "~@" + classoid))) (t (unless (eq (classoid-layout classoid) layout) (register-layout layout :invalidate nil)) @@ -1274,28 +1310,6 @@ (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S" old-layout) (values class new-layout old-layout))))))))) - -;;; Blow away all the compiler info for the structure CLASS. Iterate -;;; over this type, clearing the compiler structure type info, and -;;; undefining all the associated functions. -(defun undefine-structure (class) - (let ((info (layout-info (classoid-layout class)))) - (when (defstruct-description-p info) - (let ((type (dd-name info))) - (remhash type *typecheckfuns*) - (setf (info :type :compiler-layout type) nil) - (undefine-fun-name (dd-copier-name info)) - (undefine-fun-name (dd-predicate-name info)) - (dolist (slot (dd-slots info)) - (let ((fun (dsd-accessor-name slot))) - (unless (accessor-inherited-data fun info) - (undefine-fun-name fun) - (unless (dsd-read-only slot) - (undefine-fun-name `(setf ,fun))))))) - ;; Clear out the SPECIFIER-TYPE cache so that subsequent - ;; references are unknown types. - (values-specifier-type-cache-clear))) - (values)) ;;; Return a list of pairs (name . index). Used for :TYPE'd ;;; constructors to find all the names that we have to splice in & diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index be0c7e8..04e3e1c 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -741,4 +741,301 @@ ;;; bug reported by John Morrison, 2008-07-22 on sbcl-devel (defstruct (raw-slot-struct-with-unknown-init (:constructor make-raw-slot-struct-with-unknown-init ())) (x (#:unknown-function) :type double-float)) + +;;; Some checks for the behavior of incompatibly redefining structure +;;; classes. We don't actually check that our detection of +;;; "incompatible" is comprehensive, only that if an incompatible +;;; definition is processed, we do various things. +(defmacro with-files ((&rest vars) &body body) + "Evaluate BODY with VARS bound to a number of filenames, then +delete the files at the end." + (let* ((paths (loop for var in vars + as index upfrom 0 + collect (make-pathname + :case :common + :name (format nil + "DEFSTRUCT-REDEF-TEST-~D" + index) + :type "LISP"))) + (binding-spec (mapcar + (lambda (var path) `(,var ,path)) vars paths))) + (labels ((frob (n) + `((unwind-protect + (progn + ,@(if (plusp n) + (frob (1- n)) + body)) + (delete-file ,(elt paths n)))))) + `(let ,binding-spec + ,@(frob (1- (length vars))))))) + +(defun noclobber (pathspec &rest forms) + "Write FORMS to the file named by PATHSPEC, erroring if +PATHSPEC already names an existing file." + (with-open-file (*standard-output* pathspec :direction :output + :if-exists :error) + (print '(in-package "CL-USER")) + (mapc #'print forms))) + +(defun compile-file-assert (file &optional (want-error-p t) (want-warning-p t)) + "Compile FILE and assert some things about the results." + (multiple-value-bind (fasl errors-p warnings-p) + (compile-file file) + (assert fasl) + (assert (eq errors-p want-error-p)) + (assert (eq warnings-p want-warning-p)) + fasl)) + +(defun continue-from-incompatible-defstruct-error (error) + "Invoke the CONTINUE restart for an incompatible DEFSTRUCT +redefinition." + ;; FIXME: want distinct error type for incompatible defstruct. + (when (search "attempt to redefine" (simple-condition-format-control error)) + (when (find-restart 'continue) + (invoke-restart 'continue)))) + +(defun recklessly-continue-from-incompatible-defstruct-error (error) + "Invoke the RECKLESSLY-CONTINUE restart for an incompatible DEFSTRUCT +redefinition." + ;; FIXME: want distinct error type for incompatible defstruct. + (when (search "attempt to redefine" (simple-condition-format-control error)) + (when (find-restart 'sb-kernel::recklessly-continue) + (invoke-restart 'sb-kernel::recklessly-continue)))) + +(defun assert-is (predicate instance) + (assert (funcall predicate instance))) + +(defun assert-invalid (predicate instance) + (assert (typep (nth-value 1 (ignore-errors (funcall predicate instance))) + 'sb-kernel::layout-invalid))) + +;; Don't try to understand this macro; just look at its expansion. +(defmacro with-defstruct-redefinition-test (name + (&rest defstruct-form-bindings) + (&rest path-form-specs) + handler-function + &body body) + (labels ((make-defstruct-form (&key class-name super-name slots) + (let* ((predicate-name + (read-from-string (format nil "~A-p" class-name))) + (constructor-name + (read-from-string (format nil "make-~A" class-name)))) + `(values + '(defstruct (,class-name + (:constructor ,constructor-name) + ,@(when super-name + `((:include ,super-name)))) + ,@slots) + ',constructor-name + ',predicate-name))) + (frob (bindspecs classno) + (if bindspecs + `((multiple-value-bind ,(first (first bindspecs)) + ,(apply #'make-defstruct-form (rest (first bindspecs))) + (declare (ignorable ,@(first (first bindspecs)))) + ,@(frob (rest bindspecs) (1+ classno)))) + `((with-files ,(mapcar #'first path-form-specs) + ,@(mapcar (lambda (path-form) `(noclobber ,@path-form)) + path-form-specs) + (handler-bind + ((simple-error ',handler-function)) + ,@body)))))) + `(with-test (:name ,name) + ,(first (frob defstruct-form-bindings 0))))) + +;; When eyeballing these, it's helpful to see when various things are +;; happening. +(setq *compile-verbose* t *load-verbose* t) + +;;; Tests begin. +;; Base case: recklessly-continue. +(with-defstruct-redefinition-test defstruct/recklessly + (((defstruct ctor pred) :class-name redef-test-1 :slots (a)) + ((defstruct*) :class-name redef-test-1 :slots (a b))) + ((path1 defstruct) + (path2 defstruct*)) + recklessly-continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load path2) + (assert-is pred instance))) + +;; Base case: continue (i.e., invalidate instances). +(with-defstruct-redefinition-test defstruct/continue + (((defstruct ctor pred) :class-name redef-test-2 :slots (a)) + ((defstruct*) :class-name redef-test-2 :slots (a b))) + ((path1 defstruct) + (path2 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load path2) + (assert-invalid pred instance))) + +;; Compiling a file with an incompatible defstruct should emit a +;; warning and an error, but the fasl should be loadable. +(with-defstruct-redefinition-test defstruct/compile-file-should-warn + (((defstruct) :class-name redef-test-3 :slots (a)) + ((defstruct*) :class-name redef-test-3 :slots (a b))) + ((path1 defstruct) + (path2 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (load (compile-file-assert path2))) + +;; After compiling a file with an incompatible DEFSTRUCT, load the +;; fasl and ensure that an old instance remains valid. +(with-defstruct-redefinition-test defstruct/compile-file-reckless + (((defstruct ctor pred) :class-name redef-test-4 :slots (a)) + ((defstruct*) :class-name redef-test-4 :slots (a b))) + ((path1 defstruct) + (path2 defstruct*)) + recklessly-continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load (compile-file-assert path2)) + (assert-is pred instance))) + +;; After compiling a file with an incompatible DEFSTRUCT, load the +;; fasl and ensure that an old instance has become invalid. +(with-defstruct-redefinition-test defstruct/compile-file-continue + (((defstruct ctor pred) :class-name redef-test-5 :slots (a)) + ((defstruct*) :class-name redef-test-5 :slots (a b))) + ((path1 defstruct) + (path2 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load (compile-file-assert path2)) + (assert-invalid pred instance))) + +;;; Subclasses. +;; Ensure that recklessly continuing DT(expected)T to instances of +;; subclasses. (This is a case where recklessly continuing is +;; actually dangerous, but we don't care.) +(with-defstruct-redefinition-test defstruct/subclass-reckless + (((defstruct ignore pred1) :class-name redef-test-6 :slots (a)) + ((substruct ctor pred2) :class-name redef-test-6-sub + :super-name redef-test-6 :slots (z)) + ((defstruct*) :class-name redef-test-6 :slots (a b))) + ((path1 defstruct substruct) + (path2 defstruct* substruct)) + recklessly-continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load (compile-file-assert path2)) + (assert-is pred1 instance) + (assert-is pred2 instance))) + +;; Ensure that continuing invalidates instances of subclasses. +(with-defstruct-redefinition-test defstruct/subclass-continue + (((defstruct) :class-name redef-test-7 :slots (a)) + ((substruct ctor pred) :class-name redef-test-7-sub + :super-name redef-test-7 :slots (z)) + ((defstruct*) :class-name redef-test-7 :slots (a b))) + ((path1 defstruct substruct) + (path2 defstruct* substruct)) + continue-from-incompatible-defstruct-error + (load path1) + (let ((instance (funcall ctor))) + (load (compile-file-assert path2)) + (assert-invalid pred instance))) + +;; Reclkessly continuing doesn't invalidate instances of subclasses. +(with-defstruct-redefinition-test defstruct/subclass-in-other-file-reckless + (((defstruct ignore pred1) :class-name redef-test-8 :slots (a)) + ((substruct ctor pred2) :class-name redef-test-8-sub + :super-name redef-test-8 :slots (z)) + ((defstruct*) :class-name redef-test-8 :slots (a b))) + ((path1 defstruct) + (path2 substruct) + (path3 defstruct*)) + recklessly-continue-from-incompatible-defstruct-error + (load path1) + (load path2) + (let ((instance (funcall ctor))) + (load (compile-file-assert path3)) + (assert-is pred1 instance) + (assert-is pred2 instance))) + +;; This is an icky case: when a subclass is defined in a separate +;; file, CONTINUE'ing from LOAD of a file containing an incompatible +;; superclass definition leaves the predicates and accessors into the +;; subclass in a bad way until the subclass form is evaluated. +(with-defstruct-redefinition-test defstruct/subclass-in-other-file-continue + (((defstruct ignore pred1) :class-name redef-test-9 :slots (a)) + ((substruct ctor pred2) :class-name redef-test-9-sub + :super-name redef-test-9 :slots (z)) + ((defstruct*) :class-name redef-test-9 :slots (a b))) + ((path1 defstruct) + (path2 substruct) + (path3 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (load path2) + (let ((instance (funcall ctor))) + (load (compile-file-assert path3)) + ;; At this point, the instance of the subclass will not count as + ;; an instance of the superclass or of the subclass, but PRED2's + ;; predicate will error with "an obsolete structure accessor + ;; function was called". + (assert-invalid pred1 instance) + (format t "~&~A~%" (nth-value 1 (ignore-errors (funcall pred2 instance)))) + ;; After loading PATH2, we'll get the desired LAYOUT-INVALID error. + (load path2) + (assert-invalid pred2 instance))) + +;; Some other subclass wrinkles have to do with splitting definitions +;; accross files and compiling and loading things in a funny order. +(with-defstruct-redefinition-test + defstruct/subclass-in-other-file-funny-operation-order-continue + (((defstruct ignore pred1) :class-name redef-test-10 :slots (a)) + ((substruct ctor pred2) :class-name redef-test-10-sub + :super-name redef-test-10 :slots (z)) + ((defstruct*) :class-name redef-test-10 :slots (a b))) + ((path1 defstruct) + (path2 substruct) + (path3 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (load path2) + (let ((instance (funcall ctor))) + ;; First we clobber the compiler's layout for the superclass. + (compile-file-assert path3) + ;; Then we recompile the subclass definition (which generates a + ;; warning about the compiled layout for the superclass being + ;; incompatible with the loaded layout, because we haven't loaded + ;; path3 since recompiling). + (compile-file path2) + ;; Ugh. I don't want to think about loading these in the wrong + ;; order. + (load (compile-file-pathname path3)) + (load (compile-file-pathname path2)) + (assert-invalid pred1 instance) + (assert-invalid pred2 instance))) + +(with-defstruct-redefinition-test + defstruct/subclass-in-other-file-funny-operation-order-continue + (((defstruct ignore pred1) :class-name redef-test-11 :slots (a)) + ((substruct ctor pred2) :class-name redef-test-11-sub + :super-name redef-test-11 :slots (z)) + ((defstruct*) :class-name redef-test-11 :slots (a b))) + ((path1 defstruct) + (path2 substruct) + (path3 defstruct*)) + continue-from-incompatible-defstruct-error + (load path1) + (load path2) + (let ((instance (funcall ctor))) + ;; This clobbers the compiler's layout for REDEF-TEST-11. + (compile-file-assert path3) + ;; This recompiles REDEF-TEST-11-SUB, using the new REDEF-TEST-11 + ;; compiler-layout. + (load (compile-file-pathname path2)) + ;; Note that because we haven't loaded PATH3, we haven't clobbered + ;; the class's layout REDEF-TEST-11, so REDEF-11's predicate will + ;; still work. That's probably bad. + (assert-is pred1 instance) + (assert-is pred2 instance))) + diff --git a/version.lisp-expr b/version.lisp-expr index 648ad9e..6c94b7e 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.20.24" +"1.0.20.25" -- 1.7.10.4