[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Redefinition of classes having existing instances

Redefinition of classes having existing instances can make 
the old instances unusable because of two bugs.  Here are
test cases and fixes for both bugs.

  Richard Harris

;1. Fix a bug in invalidate-wrapper: when the state is obsolete,
;   the state of every previous wrapper must be changed to obsolete.
;   [added the form (when (eq state 'obsolete) ...).]

(defclass c1 () ())
(defclass c1a () ())
(defclass c3 (c1) ((a :initform 'one))))
(defmethod test ((v c3)) (slot-value v 'a))
(print (test (setq z1 (make-instance 'c3)))) ; => ONE
(defclass c3 (c1a) ((a :initform 'one))))
(defclass c2 () ((b :initform 'two)))
(defclass c3 (c2) ((a :initform 'one)))
(print (test (setq z2 (make-instance 'c3)))) ; => ONE
(defclass c2 () ((b :initform 'two))) 
(print (test z2))                            ; => TWO
(print (test z1))                            ; error

 - - - - - - - - - - - - 
(defun invalidate-wrapper (owrapper state nwrapper)
  (ecase state
    ((flush obsolete)
     (let ((new-previous ()))
       ;; First off, a previous call to invalidate-wrapper may have recorded
       ;; owrapper as an nwrapper to update to.  Since owrapper is about to
       ;; be invalid, it no longer makes sense to update to it.
       ;; We go back and change the previously invalidated wrappers so that
       ;; they will now update directly to nwrapper.  This corresponds to a
       ;; kind of transitivity of wrapper updates.
       (dolist (previous (gethash owrapper *previous-nwrappers*))
	 (when (eq state 'obsolete)          ; obsolete must override flush
	   (setf (car previous) 'obsolete))
	 (setf (cadr previous) nwrapper)
	 (push previous new-previous))
       (iterate ((type (list-elements wrapper-layout))
		 (i (interval :from 0)))
	 (when (eq type 'number) (setf (wrapper-ref owrapper i) 0)))
       (push (setf (wrapper-state owrapper) (list state nwrapper))
       (setf (gethash owrapper *previous-nwrappers*) ()
	     (gethash nwrapper *previous-nwrappers*) new-previous)))))

;2. The code generated by add-pv-binding (called by defmethod) is not 
    prepared to handle cache misses caused by invalid wrappers, but 
    discriminating functions which call protect-cache-miss-code do not 
    always call check-wrapper-validity.


(defclass c1 () ())
(defclass c2 () ((b :initform 'two)))
(defclass c3 (c2) ((a :initform 'one)))

(defvar *list1*)
(setq *list1* (list (make-instance 'c3) (make-instance 'c3)))
(defvar *list2*)
(setq *list2* (list (make-instance 'c3) (make-instance 'c3)))

(defclass c3 (c1) ((a :initform 'one))))
(defclass c3 (c2) ((a :initform 'one)))

(defmethod test-list ((v c3) &rest list)
  (if list
      (cons (slot-value v 'a) (apply #'test-list list))
      (list (slot-value v 'a))))

(pcl::invalidate-discriminating-function #'test-list)

(print (apply #'test-list *list1*)) ; => (TWO TWO)
(print (apply #'test-list *list2*)) ; => (TWO TWO); (ONE TWO) if invalidate-wrapper is fixed

 - - - - - - - - - - - - 
(defmacro protect-cache-miss-code (gf args &body body)
  (let ((wrappers (gensym)) (invalidp (gensym)) (function (gensym)) (appl (gensym)))
    (once-only (gf args)
      `(if (memq ,gf *invalid-dfuns-on-stack*)
	   (multiple-value-bind (,wrappers ,invalidp ,function ,appl)
	       (cache-miss-values ,gf ,args)
             (declare (ignore ,wrappers ,invalidp))
	     (if (null ,appl)
		 (no-applicable-method ,gf ,args) ; or maybe (apply #'no-applicable-method ,gf ,args)
		 (apply ,function ,args)))
	   (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*)))