X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=9cd4e01a3326cf9f66b21d659dc24eb45d57803d;hb=d7cbe5c40e93796d326937f3fb962fa4d7b1fa85;hp=d67e1c4775f0f5dd50aa7d0ea90c7c3faf89f269;hpb=4aa08cf49281110c94f534a8e118bb8fcbfc18db;p=sbcl.git diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index d67e1c4..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 @@ -124,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 @@ -154,43 +153,67 @@ (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 +;;; 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))) - (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 - (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. + (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) @@ -230,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)))