Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv5275/src/pcl
Modified Files:
braid.lisp cache.lisp slots-boot.lisp slots.lisp
std-class.lisp
Log Message:
0.7.9.12:
Fix for BUG 140 (not opening bug 176 this time) from Gerd Moellmann,
on cmucl-imp 86fzuwdkmy.fsf@... and
private communication;
entomotomy reference: redefined-classes-and-subtypep
... slightly kludgy logic in FORCE-CACHE-FLUSHES
... break me if you can
BUGS frobbage, too; delete several old bugs that are probably
fixed now.
Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- braid.lisp 29 Oct 2002 10:02:30 -0000 1.24
+++ braid.lisp 29 Oct 2002 12:48:20 -0000 1.25
@@ -578,7 +578,7 @@
(sb-kernel:order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class))))))
- (sb-kernel:register-layout layout :invalidate nil)
+ (sb-kernel:register-layout layout :invalidate t)
;; Subclasses of formerly forward-referenced-class may be
;; unknown to CL:FIND-CLASS and also anonymous. This
Index: cache.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- cache.lisp 26 Oct 2002 11:00:11 -0000 1.25
+++ cache.lisp 29 Oct 2002 12:48:21 -0000 1.26
@@ -261,44 +261,6 @@
(defmacro wrapper-no-of-instance-slots (wrapper)
`(sb-kernel:layout-length ,wrapper))
-;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly)
-;;; iff the wrapper is valid. Any other return value denotes some
-;;; invalid state. Special conventions have been set up for certain
-;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN
-;;; 19991204) haven't been motivated to reverse engineer them from the
-;;; code and document them here.
-;;;
-;;; FIXME: We have removed the persistent use of this function throughout
-;;; the PCL codebase, instead opting to use INVALID-WRAPPER-P, which
-;;; abstractly tests the return result of this function for invalidness.
-;;; However, part of the original comment that is still applicable follows.
-;;; --njf, 2002-05-02
-;;;
-;;; FIXME: It would probably be even better to switch the sense of the
-;;; WRAPPER-STATE function, renaming it to WRAPPER-INVALID and making it
-;;; synonymous with LAYOUT-INVALID. Then the INVALID-WRAPPER-P function
-;;; would become trivial and would go away (replaced with
-;;; WRAPPER-INVALID), since all the various invalid wrapper states would
-;;; become generalized boolean "true" values. -- WHN 19991204
-#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
-(defun wrapper-state (wrapper)
- (let ((invalid (sb-kernel:layout-invalid wrapper)))
- (cond ((null invalid)
- t)
- ((atom invalid)
- ;; some non-PCL object. INVALID is probably :INVALID. We
- ;; should arguably compute the new wrapper here instead of
- ;; returning NIL, but we don't bother, since
- ;; OBSOLETE-INSTANCE-TRAP can't use it.
- '(:obsolete nil))
- (t
- invalid))))
-(defun (setf wrapper-state) (new-value wrapper)
- (setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value t)
- nil
- new-value)))
-
(defmacro wrapper-instance-slots-layout (wrapper)
`(%wrapper-instance-slots-layout ,wrapper))
(defmacro wrapper-class-slots (wrapper)
@@ -411,63 +373,52 @@
(declaim (inline invalid-wrapper-p))
(defun invalid-wrapper-p (wrapper)
- (neq (wrapper-state wrapper) t))
+ (not (null (sb-kernel:layout-invalid wrapper))))
(defvar *previous-nwrappers* (make-hash-table))
(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)
- (setf (car previous) :obsolete))
- (setf (cadr previous) nwrapper)
- (push previous new-previous))
+ (aver (member state '(:flush :obsolete) :test #'eq))
+ (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)
+ (setf (car previous) :obsolete))
+ (setf (cadr previous) nwrapper)
+ (push previous new-previous))
- (let ((ocnv (wrapper-cache-number-vector owrapper)))
- (dotimes (i sb-kernel:layout-clos-hash-length)
- (setf (cache-number-vector-ref ocnv i) 0)))
- (push (setf (wrapper-state owrapper) (list state nwrapper))
- new-previous)
+ (let ((ocnv (wrapper-cache-number-vector owrapper)))
+ (dotimes (i sb-kernel:layout-clos-hash-length)
+ (setf (cache-number-vector-ref ocnv i) 0)))
- (setf (gethash owrapper *previous-nwrappers*) ()
- (gethash nwrapper *previous-nwrappers*) new-previous)))))
+ (push (setf (sb-kernel:layout-invalid owrapper) (list state nwrapper))
+ new-previous)
+
+ (setf (gethash owrapper *previous-nwrappers*) ()
+ (gethash nwrapper *previous-nwrappers*) new-previous)))
(defun check-wrapper-validity (instance)
- (let* ((owrapper (wrapper-of instance)))
- (if (not (invalid-wrapper-p owrapper))
+ (let* ((owrapper (wrapper-of instance))
+ (state (sb-kernel:layout-invalid owrapper)))
+ (if (null state)
owrapper
- (let* ((state (wrapper-state owrapper))
- (nwrapper
- (ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (obsolete-instance-trap owrapper (cadr state) instance)))))
- ;; This little bit of error checking is superfluous. It only
- ;; checks to see whether the person who implemented the trap
- ;; handling screwed up. Since that person is hacking
- ;; internal PCL code, and is not a user, this should be
- ;; needless. Also, since this directly slows down instance
- ;; update and generic function cache refilling, feel free to
- ;; take it out sometime soon.
- ;;
- ;; FIXME: We probably need to add a #+SB-PARANOID feature to
- ;; make stuff like this optional. Until then, it stays in.
- (cond ((neq nwrapper (wrapper-of instance))
- (error "wrapper returned from trap not wrapper of instance"))
- ((invalid-wrapper-p nwrapper)
- (error "wrapper returned from trap invalid")))
- nwrapper))))
+ (ecase (car state)
+ (:flush
+ (flush-cache-trap owrapper (cadr state) instance))
+ (:obsolete
+ (obsolete-instance-trap owrapper (cadr state) instance))))))
+
+(declaim (inline check-obsolete-instance))
+(defun check-obsolete-instance (instance)
+ (when (invalid-wrapper-p (sb-kernel:layout-of instance))
+ (check-wrapper-validity instance)))
(defvar *free-caches* nil)
Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- slots-boot.lisp 3 Oct 2002 02:00:24 -0000 1.13
+++ slots-boot.lisp 29 Oct 2002 12:48:21 -0000 1.14
@@ -99,18 +99,21 @@
(etypecase index
(fixnum (if fsc-p
(lambda (instance)
+ (check-obsolete-instance instance)
(let ((value (clos-slots-ref (fsc-instance-slots instance)
index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
value)))
(lambda (instance)
+ (check-obsolete-instance instance)
(let ((value (clos-slots-ref (std-instance-slots instance)
index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
value)))))
(cons (lambda (instance)
+ (check-obsolete-instance instance)
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(slot-unbound (class-of instance) instance slot-name)
@@ -123,13 +126,15 @@
(etypecase index
(fixnum (if fsc-p
(lambda (nv instance)
+ (check-obsolete-instance instance)
(setf (clos-slots-ref (fsc-instance-slots instance) index)
nv))
(lambda (nv instance)
+ (check-obsolete-instance instance)
(setf (clos-slots-ref (std-instance-slots instance) index)
nv))))
(cons (lambda (nv instance)
- (declare (ignore instance))
+ (check-obsolete-instance instance)
(setf (cdr index) nv))))
`(writer ,slot-name)))
@@ -139,15 +144,17 @@
(etypecase index
(fixnum (if fsc-p
(lambda (instance)
+ (check-obsolete-instance instance)
(not (eq (clos-slots-ref (fsc-instance-slots instance)
index)
+slot-unbound+)))
(lambda (instance)
+ (check-obsolete-instance instance)
(not (eq (clos-slots-ref (std-instance-slots instance)
index)
+slot-unbound+)))))
(cons (lambda (instance)
- (declare (ignore instance))
+ (check-obsolete-instance instance)
(not (eq (cdr index) +slot-unbound+)))))
`(boundp ,slot-name)))
@@ -201,7 +208,7 @@
(fixnum (if fsc-p
(lambda (class instance slotd)
(declare (ignore slotd))
- (unless (fsc-instance-p instance) (error "not fsc"))
+ (check-obsolete-instance instance)
(let ((value (clos-slots-ref (fsc-instance-slots instance)
index)))
(if (eq value +slot-unbound+)
@@ -209,7 +216,7 @@
value)))
(lambda (class instance slotd)
(declare (ignore slotd))
- (unless (std-instance-p instance) (error "not std"))
+ (check-obsolete-instance instance)
(let ((value (clos-slots-ref (std-instance-slots instance)
index)))
(if (eq value +slot-unbound+)
@@ -217,6 +224,7 @@
value)))))
(cons (lambda (class instance slotd)
(declare (ignore slotd))
+ (check-obsolete-instance instance)
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(slot-unbound class instance slot-name)
@@ -230,14 +238,17 @@
(fixnum (if fsc-p
(lambda (nv class instance slotd)
(declare (ignore class slotd))
+ (check-obsolete-instance instance)
(setf (clos-slots-ref (fsc-instance-slots instance) index)
nv))
(lambda (nv class instance slotd)
(declare (ignore class slotd))
+ (check-obsolete-instance instance)
(setf (clos-slots-ref (std-instance-slots instance) index)
nv))))
(cons (lambda (nv class instance slotd)
- (declare (ignore class instance slotd))
+ (declare (ignore class slotd))
+ (check-obsolete-instance instance)
(setf (cdr index) nv)))))
(defun make-optimized-std-slot-boundp-using-class-method-function
@@ -248,14 +259,17 @@
(fixnum (if fsc-p
(lambda (class instance slotd)
(declare (ignore class slotd))
+ (check-obsolete-instance instance)
(not (eq (clos-slots-ref (fsc-instance-slots instance) index)
+slot-unbound+)))
(lambda (class instance slotd)
(declare (ignore class slotd))
+ (check-obsolete-instance instance)
(not (eq (clos-slots-ref (std-instance-slots instance) index)
+slot-unbound+)))))
(cons (lambda (class instance slotd)
- (declare (ignore class instance slotd))
+ (declare (ignore class slotd))
+ (check-obsolete-instance instance)
(not (eq (cdr index) +slot-unbound+))))))
(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- slots.lisp 18 May 2002 22:13:07 -0000 1.10
+++ slots.lisp 29 Oct 2002 12:48:21 -0000 1.11
@@ -187,19 +187,14 @@
(defmethod slot-value-using-class ((class std-class)
(object std-object)
(slotd standard-effective-slot-definition))
+ (check-obsolete-instance object)
(let* ((location (slot-definition-location slotd))
(value (typecase location
(fixnum
(cond ((std-instance-p object)
- (when (invalid-wrapper-p (std-instance-wrapper
- object))
- (check-wrapper-validity object))
(clos-slots-ref (std-instance-slots object)
location))
((fsc-instance-p object)
- (when (invalid-wrapper-p (fsc-instance-wrapper
- object))
- (check-wrapper-validity object))
(clos-slots-ref (fsc-instance-slots object)
location))
(t (error "unrecognized instance type"))))
@@ -218,19 +213,16 @@
(new-value (class std-class)
(object std-object)
(slotd standard-effective-slot-definition))
+ (check-obsolete-instance object)
(let ((location (slot-definition-location slotd)))
(typecase location
(fixnum
(cond ((std-instance-p object)
- (when (invalid-wrapper-p (std-instance-wrapper object))
- (check-wrapper-validity object))
- (setf (clos-slots-ref (std-instance-slots object) location)
- new-value))
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ new-value))
((fsc-instance-p object)
- (when (invalid-wrapper-p (fsc-instance-wrapper object))
- (check-wrapper-validity object))
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- new-value))
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ new-value))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) new-value))
@@ -243,19 +235,14 @@
((class std-class)
(object std-object)
(slotd standard-effective-slot-definition))
+ (check-obsolete-instance object)
(let* ((location (slot-definition-location slotd))
(value (typecase location
(fixnum
(cond ((std-instance-p object)
- (when (invalid-wrapper-p (std-instance-wrapper
- object))
- (check-wrapper-validity object))
(clos-slots-ref (std-instance-slots object)
location))
((fsc-instance-p object)
- (when (invalid-wrapper-p (fsc-instance-wrapper
- object))
- (check-wrapper-validity object))
(clos-slots-ref (fsc-instance-slots object)
location))
(t (error "unrecognized instance type"))))
@@ -272,19 +259,16 @@
((class std-class)
(object std-object)
(slotd standard-effective-slot-definition))
+ (check-obsolete-instance object)
(let ((location (slot-definition-location slotd)))
(typecase location
(fixnum
(cond ((std-instance-p object)
- (when (invalid-wrapper-p (std-instance-wrapper object))
- (check-wrapper-validity object))
- (setf (clos-slots-ref (std-instance-slots object) location)
- +slot-unbound+))
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ +slot-unbound+))
((fsc-instance-p object)
- (when (invalid-wrapper-p (fsc-instance-wrapper object))
- (check-wrapper-validity object))
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- +slot-unbound+))
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ +slot-unbound+))
(t (error "unrecognized instance type"))))
(cons
(setf (cdr location) +slot-unbound+))
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- std-class.lisp 28 Oct 2002 14:33:31 -0000 1.29
+++ std-class.lisp 29 Oct 2002 12:48:21 -0000 1.30
@@ -1050,12 +1050,17 @@
(defun force-cache-flushes (class)
(let* ((owrapper (class-wrapper class)))
- ;; We only need to do something if the state is still T. If the
- ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
- ;; will already be doing what we want. In particular, we must be
- ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
- ;; means do what FLUSH does and then some.
- (unless (invalid-wrapper-p owrapper)
+ ;; We only need to do something if the wrapper is still valid. If
+ ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
+ ;; both of those will already be doing what we want. In
+ ;; particular, we must be sure we never change an OBSOLETE into a
+ ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
+ (when (or (not (invalid-wrapper-p owrapper))
+ ;; Ick. LAYOUT-INVALID can return a list (which we can
+ ;; handle), T (which we can't), NIL (which is handled by
+ ;; INVALID-WRAPPER-P) or :UNINITIALIZED (which never
+ ;; gets here (I hope). -- CSR, 2002-10-28
+ (eq (sb-kernel:layout-invalid owrapper) t))
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
|