diff --git a/pcl/braid.lisp b/pcl/braid.lisp index b8392009ccd0a86f253ad97157a00caf516bf20c..3ba23a4c5906850d09c3ef37413032c7188dcd10 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.25 2002/10/19 14:56:02 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.26 2002/10/29 16:20:44 pmai Exp $") ;;; ;;; Bootstrapping the meta-braid. ;;; @@ -566,13 +566,8 @@ (kernel:order-layout-inherits (map 'simple-vector #'class-wrapper (reverse (rest (class-precedence-list class)))))) - - ;; The invalidate nil is wrong, since it leaves the CMUCL type-system - ;; with obsolete information, but fixing it requires extensive changes - ;; to the PCL instance-updating mechanism, which relies on access to - ;; the old wrapper. - (kernel:register-layout layout :invalidate nil) - + (kernel:register-layout layout :invalidate t) + ;; ;; Subclasses of formerly forward-referenced-class may be unknown ;; to lisp:find-class and also anonymous. This functionality moved ;; here from (setf find-class). diff --git a/pcl/cache.lisp b/pcl/cache.lisp index a38a424044c1ebf16d3e46aa94ea77fc16c9e164..a2955d72841fc371c4c0cef0f74ddc844979699b 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.20 2002/10/19 01:11:41 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.21 2002/10/29 16:20:44 pmai Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; @@ -312,26 +312,6 @@ `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) (defmacro wrapper-no-of-instance-slots (wrapper) `(kernel:layout-length ,wrapper)) -(declaim (inline wrapper-state (setf wrapper-state))) - -(defun wrapper-state (wrapper) - (let ((invalid (kernel:layout-invalid wrapper))) - (cond ((null invalid) - t) - ((atom invalid) - ;; Some non-pcl object. invalid is probably :INVALID - ;; We should compute the new wrapper here instead - ;; of returning nil, but why bother, since - ;; obsolete-instance-trap can't use it. - '(:obsolete nil)) - (t - invalid)))) - -(defun (setf wrapper-state) (new-value wrapper) - (setf (kernel:layout-invalid wrapper) - (if (eq new-value t) - nil - new-value))) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) @@ -448,66 +428,57 @@ ;;; validity as well. This is done by calling check-wrapper-validity. ;;; -(defmacro invalid-wrapper-p (wrapper) - `(neq (wrapper-state ,wrapper) t)) +(declaim (inline invalid-wrapper-p)) + +(defun invalid-wrapper-p (wrapper) + (not (null (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)) - - (loop with ocnv = (wrapper-cache-number-vector owrapper) - for type in wrapper-layout and i from 0 - when (eq type 'number) do - (setf (cache-number-vector-ref ocnv i) 0)) - - (push (setf (wrapper-state owrapper) (list state nwrapper)) - new-previous) - - (setf (gethash owrapper *previous-nwrappers*) () - (gethash nwrapper *previous-nwrappers*) new-previous))))) + (assert (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 (first previous) :obsolete)) + (setf (second previous) nwrapper) + (push previous new-previous)) + + (loop for i below kernel:layout-hash-length do + (setf (kernel:layout-hash owrapper i) 0)) + + (let ((new-state (list state nwrapper))) + (setf (kernel:layout-invalid owrapper) new-state) + (push new-state new-previous) + (setf (gethash owrapper *previous-nwrappers*) () + (gethash nwrapper *previous-nwrappers*) new-previous)))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) - (state (wrapper-state owrapper))) - (if (eq state t) + (state (kernel:layout-invalid owrapper))) + (if (null state) owrapper - (let ((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. - ;; - (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 (first state) + (:flush + (flush-cache-trap owrapper (second state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (second state) instance)))))) + +(declaim (inline check-obsolete-instance)) + +(defun check-obsolete-instance (instance) + (when (invalid-wrapper-p (kernel:layout-of instance)) + (check-wrapper-validity instance))) + (defvar *free-caches* nil) diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index aded320f18e2f5778e350346642d2095e0034593..6da9ee0f9b1c93c417af94ef4bab7eda29825e67 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.14 2002/10/19 15:26:10 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.15 2002/10/29 16:20:44 pmai Exp $") ;;; (in-package :pcl) @@ -113,16 +113,19 @@ (etypecase index (fixnum (if fsc-p (lambda (instance) + (check-obsolete-instance instance) (let ((value (%instance-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 (%instance-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) @@ -135,11 +138,13 @@ (etypecase index (fixnum (if fsc-p (lambda (nv instance) + (check-obsolete-instance instance) (setf (%instance-ref (fsc-instance-slots instance) index) nv)) (lambda (nv instance) + (check-obsolete-instance instance) (setf (%instance-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))) @@ -149,15 +154,17 @@ (etypecase index (fixnum (if fsc-p (lambda (instance) + (check-obsolete-instance instance) (not (eq (%instance-ref (fsc-instance-slots instance) index) +slot-unbound+))) (lambda (instance) + (check-obsolete-instance instance) (not (eq (%instance-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))) @@ -210,20 +217,21 @@ (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 (%instance-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) value))) (lambda (class instance slotd) (declare (ignore slotd)) - (unless (std-instance-p instance) (error "not std")) + (check-obsolete-instance instance) (let ((value (%instance-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) (slot-unbound class instance slot-name) 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) @@ -237,12 +245,15 @@ (fixnum (if fsc-p (lambda (nv class instance slotd) (declare (ignore class slotd)) + (check-obsolete-instance instance) (setf (%instance-ref (fsc-instance-slots instance) index) nv)) (lambda (nv class instance slotd) (declare (ignore class slotd)) + (check-obsolete-instance instance) (setf (%instance-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 @@ -253,16 +264,19 @@ (fixnum (if fsc-p (lambda (class instance slotd) (declare (ignore class slotd)) + (check-obsolete-instance instance) (not (eq (%instance-ref (fsc-instance-slots instance) index) +slot-unbound+))) (lambda (class instance slotd) (declare (ignore class slotd)) + (check-obsolete-instance instance) (not (eq (%instance-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) diff --git a/pcl/slots.lisp b/pcl/slots.lisp index 275362d744dadd38b9de5b7fbb22d62c161d5961..aa5beb05ebbda1065fe0cf39f0d6e277a5e28e0a 100644 --- a/pcl/slots.lisp +++ b/pcl/slots.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.14 2002/10/19 14:32:44 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.15 2002/10/29 16:20:45 pmai Exp $") ;;; (in-package :pcl) @@ -210,16 +210,13 @@ (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) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) (%instance-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) (%instance-ref (fsc-instance-slots object) location)) (t (error "What kind of instance is this?")))) (cons @@ -236,16 +233,13 @@ (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) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) (setf (%instance-ref (std-instance-slots object) location) new-value)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) (setf (%instance-ref (fsc-instance-slots object) location) new-value)) (t (error "What kind of instance is this?")))) (cons @@ -259,16 +253,13 @@ ((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) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) (%instance-ref (std-instance-slots object) location)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) (%instance-ref (fsc-instance-slots object) location)) (t (error "What kind of instance is this?")))) (cons @@ -283,16 +274,13 @@ ((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) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) (setf (%instance-ref (std-instance-slots object) location) +slot-unbound+)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) (setf (%instance-ref (fsc-instance-slots object) location) +slot-unbound+)) (t (error "What kind of instance is this?")))) (cons diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index e0786c16fccd3bf0ea23cd1f64697b046ec84ae6..6c8b5994dd793909c5a4c08d31e9044d119cfdc1 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.36 2002/10/19 14:56:03 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.37 2002/10/29 16:20:45 pmai Exp $") ;;; (in-package :pcl) @@ -1054,19 +1054,37 @@ ;;; +;;; Force the flushing of caches by creating a new wrapper for CLASS, +;;; if necessary. ;;; +;;; If the LAYOUT-INVALID slot of CLASS's wrapper is +;;; +;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's +;;; nothing to do. The new wrapper has already been created. +;;; +;;; -- :INVALID, then it has been set to that value by a previous +;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's +;;; wrapper has been invalidated together with its subclasses. In +;;; this case, CLASS's caches must obviously be flushed, too, like +;;; S's. So, make a new wrapper for CLASS, and translate kernel's +;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later +;;; decide if it wants to make this (:OBSOLETE ...). +;;; +;;; -- NIL, then the wrapper is still valid, in which case we do +;;; the same as for :INVALID, but for the obviously slightly +;;; different reason. ;;; (defun force-cache-flushes (class) - (let* ((owrapper (class-wrapper class)) - (state (wrapper-state owrapper))) + (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 + ;; 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 (eq state t) + (when (or (not (invalid-wrapper-p owrapper)) + (eq :invalid (kernel:layout-invalid owrapper))) (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index 6b417511c3d7c21e5cef5f3b62d6a5400633b5fe..d3e0f331afdbc3a5c2b166653afee7775e360e80 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.20 2002/10/19 14:32:45 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.21 2002/10/29 16:20:45 pmai Exp $") ;;; ;;; Permutation vectors. ;;; @@ -1064,7 +1064,7 @@ (dolist (arg args) (setq w (wrapper-of arg)) - (unless (eq 't (wrapper-state w)) + (when (invalid-wrapper-p w) (setq w (check-wrapper-validity arg))) (setf (car w-t) w)) (setq w-t (cdr w-t))