From 1439811447104b32d986bab40d6e2ed431247004 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 21 Apr 2011 09:26:58 +0000 Subject: [PATCH] 1.0.47.25: make instances obsolete if slot definition classes change Fixes lp#766271. Regression from 1.0.46.11: previously SLOT-VALUE-USING-CLASS inhibited using permutation vectors, so not obsoleting the instances didn't cause so easily observed symptoms. Now, however, since slot-infos from the previous definition can live in the method cache, the wrappers must be invalidated so that caches are flushed properly. --- NEWS | 2 ++ src/pcl/std-class.lisp | 34 ++++++++++++++++++++++--- tests/mop.impure.lisp | 66 ++++++++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 99 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index 67170de..28dacdc 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,8 @@ changes relative to sbcl-1.0.47: (lp#721457) * bug fix: memory fault from printing a malformed simple-condition. (lp#705690) + * bug fix: redefining classes so that slot-definition classes change now + engages the obsolete instance protocol. (lp#766271) changes in sbcl-1.0.47 relative to sbcl-1.0.46: * bug fix: fix mach port rights leaks in mach exception handling code on diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 4e2604f..ab7cb21 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -915,6 +915,32 @@ (defun class-can-precede-p (class1 class2) (member class2 (class-can-precede-list class1) :test #'eq)) +;;; This is called from %UPDATE-SLOTS when layout doesn't seem to change. +;;; SLOT-INFO structures from old slotds may have been cached in permutation +;;; vectors, but new slotds have had new ones allocated to them. +;;; +;;; This is non-problematic for standard slotds, because we know the structure +;;; is compatible, but if a slot definition class changes, this can change the +;;; way SLOT-VALUE-USING-CLASS should dispatch. +;;; +;;; So, compare all slotd classes, and return T if all remain the same. +(defun slotd-classes-eq (oslotds nslotds) + (labels ((pop-nslotd (name) + (aver nslotds) + ;; Most of the time the first slot is right, but because the + ;; order of instance and non-instance slots can change without + ;; layout changing we cannot rely on that. + (let ((n (pop nslotds))) + (if (eq name (slot-definition-name n)) + n + (prog1 + (pop-nslotd name) + (push n nslotds)))))) + (loop while oslotds + for o = (pop oslotds) + for n = (pop-nslotd (slot-definition-name o)) + always (eq (class-of o) (class-of n))))) + (defun %update-slots (class eslotds) (let ((instance-slots ()) (class-slots ())) @@ -942,10 +968,10 @@ (cond ((null owrapper) (make-wrapper nslots class)) ((and (equal nlayout olayout) - (not - (loop for o in owrapper-class-slots - for n in nwrapper-class-slots - do (unless (eq (car o) (car n)) (return t))))) + (loop for o in owrapper-class-slots + for n in nwrapper-class-slots + always (eq (car o) (car n))) + (slotd-classes-eq (slot-value class 'slots) eslotds)) owrapper) (t ;; This will initialize the new wrapper to have the diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 0f3b115..96904b8 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -579,5 +579,71 @@ (let ((object (make-instance 'sbuc-mio-test-object))) (slot-value object 'slot))))))) (assert (= 1 *sbuc-counter*))) + +;;; Redefining classes so that slot definition class changes. +(defclass func-slot-class (standard-class) + ()) + +(defmethod sb-mop:validate-superclass ((class func-slot-class) (super standard-class)) + t) + +(defclass func-slot-definition () + ((function :initform nil :initarg :function :reader slotd-function))) + +(defclass effective-func-slot-definition (sb-mop:standard-effective-slot-definition + func-slot-definition) + ()) + +(defclass direct-func-slot-definition (sb-mop:standard-direct-slot-definition + func-slot-definition) + ()) + +(defmethod sb-mop:slot-value-using-class ((class func-slot-class) + instance + (slotd effective-func-slot-definition)) + (funcall (slotd-function slotd) (call-next-method))) + +(defvar *func-slot*) + +(defmethod sb-mop:effective-slot-definition-class ((class func-slot-class) &key) + (if *func-slot* + (find-class 'effective-func-slot-definition) + (call-next-method))) + +(defmethod sb-mop:direct-slot-definition-class ((class func-slot-class) &key) + (find-class 'direct-func-slot-definition)) + +(defmethod sb-mop:compute-effective-slot-definition ((class func-slot-class) name dslotds) + (let* ((*func-slot* (some #'slotd-function dslotds)) + (slotd (call-next-method))) + (when *func-slot* + (setf (slot-value slotd 'function) (fdefinition *func-slot*))) + slotd)) + +(with-test (:name :class-redefinition-changes-custom-slot-type) + (eval `(defclass func-slot-object () + ((foo :initarg :foo :reader foofoo)) + (:metaclass func-slot-class))) + (let ((x (cons t t))) + (assert (eq x (foofoo (make-instance 'func-slot-object :foo x))))) + (eval `(defclass func-slot-object () + ((foo :initarg :foo :reader foofoo :function car)) + (:metaclass func-slot-class))) + (let* ((x (cons t t)) + (y (list x))) + (assert (eq x (foofoo (make-instance 'func-slot-object :foo y)))))) + +(with-test (:name :class-redefinition-changes-custom-slot-type-mio) + (eval `(defclass func-slot-object2 () + ((foo :initarg :foo :reader foofoo)) + (:metaclass func-slot-class))) + (let* ((x (cons t t)) + (y (cons x x)) + (o (make-instance 'func-slot-object2 :foo y))) + (assert (eq y (foofoo o))) + (eval `(defclass func-slot-object2 () + ((foo :initarg :foo :reader foofoo :function car)) + (:metaclass func-slot-class))) + (assert (eq x (foofoo o))))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index d4d0951..ebcafab 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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.47.24" +"1.0.47.25" -- 1.7.10.4