X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=d7e804e0d5065d852381d0617d126a39951a0c19;hb=2210e113db46ab6250957826156e418d027014a0;hp=ae181daf1c9f4bb9002c8ec2c5c21e7afd2d4f38;hpb=157e21959c8023f146d6b03206aea6daa60e7b0d;p=sbcl.git diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index ae181da..d7e804e 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -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 @@ -152,47 +153,61 @@ (remhash owrapper *previous-nwrappers*) (setf (gethash nwrapper *previous-nwrappers*) new-previous))) +;;; FIXME: This is not a good name: part of the constract 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))) - (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. - (force-cache-flushes (class-of instance)) - (check-wrapper-validity instance)) - ((consp state) - (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance)))) - (t - (bug "Invalid LAYOUT-INVALID: ~S" state))))) + (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. + (%force-cache-flushes (class-of instance)) + ;; KLUDGE avoid an infinite recursion, it's still better to + ;; bail out with an AVER for server softwares. see FIXME above. + ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175 + (aver (not (eq (layout-invalid (wrapper-of instance)) t))) + (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 check-obsolete-instance/class-of (instance) +(defun valid-wrapper-of (instance) (let ((wrapper (wrapper-of instance))) - (when (invalid-wrapper-p wrapper) - (check-wrapper-validity instance)) - (wrapper-class* wrapper))) + (if (invalid-wrapper-p wrapper) + (check-wrapper-validity instance) + wrapper))) ;;; NIL: means nothing so far, no actual arg info has NILs in the ;;; metatype. @@ -221,15 +236,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)))