X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=9cd4e01a3326cf9f66b21d659dc24eb45d57803d;hb=54da325f13fb41669869aea688ae195426c0e231;hp=807a7896cc2e8613f3588e424b8fc873224d95ce;hpb=b1a1d1280f0003e0d5af9996274c95a78f188b37;p=sbcl.git diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index 807a789..9cd4e01 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -34,7 +34,7 @@ ;;; This is called in BRAID when we are making wrappers for classes ;;; whose slots are not initialized yet, and which may be built-in ;;; classes. We pass in the class name in addition to the class. -(defun boot-make-wrapper (length name &optional class) +(defun !boot-make-wrapper (length name &optional class) (let ((found (find-classoid name nil))) (cond (found @@ -99,8 +99,10 @@ (declaim (inline wrapper-class*)) (defun wrapper-class* (wrapper) (or (wrapper-class wrapper) - (ensure-non-standard-class - (classoid-name (layout-classoid wrapper))))) + (let ((classoid (layout-classoid wrapper))) + (ensure-non-standard-class + (classoid-name classoid) + classoid)))) ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This @@ -122,8 +124,7 @@ ;;; We only use this inside INVALIDATE-WRAPPER. (defvar *previous-nwrappers* (make-hash-table)) -;;; We always call this inside WITH-PCL-LOCK. -(defun invalidate-wrapper (owrapper state nwrapper) +(defun %invalidate-wrapper (owrapper state nwrapper) (aver (member state '(:flush :obsolete) :test #'eq)) (let ((new-previous ())) ;; First off, a previous call to INVALIDATE-WRAPPER may have @@ -142,10 +143,7 @@ ;; FIXME: We are here inside PCL lock, but might someone be ;; accessing the wrapper at the same time from outside the lock? - ;; Can it matter that they get 0 from one slot and a valid value - ;; from another? - (dotimes (i layout-clos-hash-length) - (setf (layout-clos-hash owrapper i) 0)) + (setf (layout-clos-hash owrapper) 0) ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER) ;; instead @@ -155,36 +153,78 @@ (remhash owrapper *previous-nwrappers*) (setf (gethash nwrapper *previous-nwrappers*) new-previous))) +;;; FIXME: This is not a good name: part of the contract here is that +;;; we return the valid wrapper, which is not obvious from the name +;;; (or the names of our callees.) (defun check-wrapper-validity (instance) - (let* ((owrapper (wrapper-of instance)) - (state (layout-invalid owrapper))) - (aver (not (eq state :uninitialized))) - (etypecase state - (null owrapper) - ;; FIXME: I can't help thinking that, while this does cure the - ;; symptoms observed from some class redefinitions, this isn't - ;; the place to be doing this flushing. Nevertheless... -- - ;; CSR, 2003-05-31 - ;; - ;; CMUCL comment: - ;; We assume in this case, that the :INVALID is from a - ;; previous call to REGISTER-LAYOUT for a superclass of - ;; INSTANCE's class. See also the comment above - ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. - ((member t) - (force-cache-flushes (class-of instance)) - (check-wrapper-validity instance)) - (cons - (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))))) + (with-world-lock () + (let* ((owrapper (wrapper-of instance)) + (state (layout-invalid owrapper))) + (aver (not (eq state :uninitialized))) + (cond ((not state) + owrapper) + ((not (layout-for-std-class-p owrapper)) + ;; Obsolete structure trap. + (%obsolete-instance-trap owrapper nil instance)) + ((eq t state) + ;; FIXME: I can't help thinking that, while this does cure + ;; the symptoms observed from some class redefinitions, + ;; this isn't the place to be doing this flushing. + ;; Nevertheless... -- CSR, 2003-05-31 + ;; + ;; CMUCL comment: + ;; We assume in this case, that the :INVALID is from a + ;; previous call to REGISTER-LAYOUT for a superclass of + ;; INSTANCE's class. See also the comment above + ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. + (let ((class (wrapper-class* owrapper))) + (%force-cache-flushes class) + ;; KLUDGE: avoid an infinite recursion, it's still better to + ;; bail out with an error for server softwares. see FIXME above. + ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175 + ;; + ;; Error message here is trying to figure out a bit more about the + ;; situation, since we don't have anything approaching a test-case + ;; for the bug. + (let ((new-state (layout-invalid (wrapper-of instance)))) + (unless (neq t new-state) + (cerror "Nevermind and recurse." 'bug + :format-control "~@<~4IProblem forcing cache flushes. Please report ~ + to sbcl-devel.~ + ~% Owrapper: ~S~ + ~% Wrapper-of: ~S~ + ~% Class-wrapper: ~S~%~:@>" + :format-arguments (mapcar (lambda (x) + (cons x (layout-invalid x))) + (list owrapper + (wrapper-of instance) + (class-wrapper class))))))) + (check-wrapper-validity instance)) + ((consp state) + (ecase (car state) + (:flush + (let ((new (cadr state))) + (cond ((std-instance-p instance) + (setf (std-instance-wrapper instance) new)) + ((fsc-instance-p instance) + (setf (fsc-instance-wrapper instance) new)) + (t + (bug "unrecognized instance type"))))) + (:obsolete + (%obsolete-instance-trap owrapper (cadr state) instance)))) + (t + (bug "Invalid LAYOUT-INVALID: ~S" state)))))) (declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) (when (invalid-wrapper-p (layout-of instance)) (check-wrapper-validity instance))) + +(defun valid-wrapper-of (instance) + (let ((wrapper (wrapper-of instance))) + (if (invalid-wrapper-p wrapper) + (check-wrapper-validity instance) + wrapper))) ;;; NIL: means nothing so far, no actual arg info has NILs in the ;;; metatype. @@ -213,15 +253,15 @@ ;;; specialize cache implementation or discrimination nets, but this ;;; has not occurred as yet. (defun raise-metatype (metatype new-specializer) - (let ((slot (find-class 'slot-class)) - (standard (find-class 'standard-class)) - (fsc (find-class 'funcallable-standard-class)) - (condition (find-class 'condition-class)) - (structure (find-class 'structure-class)) - (built-in (find-class 'built-in-class)) - (frc (find-class 'forward-referenced-class))) + (let ((slot *the-class-slot-class*) + (standard *the-class-standard-class*) + (fsc *the-class-funcallable-standard-class*) + (condition *the-class-condition-class*) + (structure *the-class-structure-class*) + (built-in *the-class-built-in-class*) + (frc *the-class-forward-referenced-class*)) (flet ((specializer->metatype (x) - (let* ((specializer-class (if (eq *boot-state* 'complete) + (let* ((specializer-class (if (eq **boot-state** 'complete) (specializer-class-or-nil x) x)) (meta-specializer (class-of specializer-class)))