From: Nikodemus Siivola Date: Tue, 29 May 2007 14:36:23 +0000 (+0000) Subject: 1.0.6.5: potential CLOS GC safety issue X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=62f25b3b18b66ae67d555ca8a05026dbf03d89e1;p=sbcl.git 1.0.6.5: potential CLOS GC safety issue * EMIT-FETCH-WRAPPER needs to emit code that checks that it has a real standard instance (as opposed to a structure) before it can pull the slots: if the structure eg. has no slots at all we would be pulling garbage into a lisp variable, which is not good (TM), though it should be non-serious on GENCGC platforms. To make this fast we add a new slot to LAYOUT: FOR-STD-CLASS-P, which is always NIL for layouts, and T for wrappers. * Remove one redundant SET-DFUN, which may have been needed in long-gone days when cache vectors were resourced, but not anymore. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 7f281c5..70370cc 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1285,7 +1285,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "IRRATIONAL" "JUST-DUMP-IT-NORMALLY" "KEY-INFO" "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR" - "LAYOUT-N-UNTAGGED-SLOTS" + "LAYOUT-N-UNTAGGED-SLOTS" "LAYOUT-FOR-STD-CLASS-P" #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" diff --git a/src/code/class.lisp b/src/code/class.lisp index 78a5432..e4cd365 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -185,7 +185,16 @@ ;; This slot is known to the C runtime support code. (n-untagged-slots 0 :type index) ;; Definition location - (source-location nil)) + (source-location nil) + ;; True IFF the layout belongs to a standand-instance or a + ;; standard-funcallable-instance -- that is, true only if the layout + ;; is really a wrapper. + ;; + ;; FIXME: If we unify wrappers and layouts this can go away, since + ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then + ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot + ;; layouts, there are no slots for it to pull.) + (for-std-class-p nil :type boolean :read-only t)) (def!method print-object ((layout layout) stream) (print-unreadable-object (layout stream :type t :identity t) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index a8bb544..3b02ee4 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1721,19 +1721,22 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function))) - ;; FIXME: How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does - ;; this need to be? - (set-dfun generic-function dfun cache info) - (let ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) - (set-funcallable-instance-function generic-function dfun) - (let ((gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) - (set-fun-name generic-function gf-name) - dfun)))) + ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can + ;; access it, and so that it's there for eg. future cache updates. + ;; + ;; How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does this need to + ;; be? + (set-dfun generic-function dfun cache info) + (let* ((early-p (early-gf-p generic-function)) + (dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) + (set-funcallable-instance-function generic-function dfun) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 486541b..4eba488 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -390,31 +390,42 @@ ,miss-tag (return ,miss-form)))) -;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the -;;; CMU/SBCL approach of using funcallable instances, that branch may -;;; run on non-pcl instances (structures). The result will be the -;;; non-wrapper layout for the structure, which will cause a miss. The -;;; "slots" will be whatever the first slot is, but will be ignored. -;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures -;;; as well as PCL fins. (defun emit-fetch-wrapper (metatype argument miss-tag &optional slot) (ecase metatype ((standard-instance) - `(cond ((std-instance-p ,argument) - ,@(when slot `((setq ,slot (std-instance-slots ,argument)))) - (std-instance-wrapper ,argument)) - ((fsc-instance-p ,argument) - ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) - (fsc-instance-wrapper ,argument)) - (t - (go ,miss-tag)))) + ;; This branch may run on non-pcl instances (structures). The + ;; result will be the non-wrapper layout for the structure, which + ;; will cause a miss. Since refencing the structure is rather iffy + ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P + ;; to ensure that we have a wrapper. + ;; + ;; FIXME: If we unify layouts and wrappers we can use + ;; instance-slots-layout instead of for-std-class-p, as if there + ;; are no layouts there are no slots to worry about. + (with-unique-names (wrapper) + `(cond + ((std-instance-p ,argument) + (let ((,wrapper (std-instance-wrapper ,argument))) + ,@(when slot + `((when (layout-for-std-class-p ,wrapper) + (setq ,slot (std-instance-slots ,argument))))) + ,wrapper)) + ((fsc-instance-p ,argument) + (let ((,wrapper (fsc-instance-wrapper ,argument))) + ,@(when slot + `((when (layout-for-std-class-p ,wrapper) + (setq ,slot (fsc-instance-slots ,argument))))) + ,wrapper)) + (t (go ,miss-tag))))) ;; Sep92 PCL used to distinguish between some of these cases (and ;; spuriously exclude others). Since in SBCL ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all ;; equivalent and inlined to each other, we can collapse some ;; spurious differences. ((class built-in-instance structure-instance condition-instance) - (when slot (error "can't do a slot reg for this metatype")) + (when slot + (bug "SLOT requested for metatype ~S, but it isnt' going to happen." + metatype)) `(wrapper-of ,argument)) ;; a metatype of NIL should never be seen here, as NIL is only in ;; the metatypes before a generic function is fully initialized. diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index a825d5c..0949623 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -66,7 +66,9 @@ ;; default of WRAPPER-INVALID. Instead of trying ;; to find out, I just overrode the LAYOUT ;; default here. -- WHN 19991204 - (invalid nil)) + (invalid nil) + ;; This allows quick testing of wrapperness. + (for-std-class-p t)) (:constructor make-wrapper-internal) (:copier nil)) (instance-slots-layout nil :type list) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index d8ce44c..9bf5e04 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1539,11 +1539,6 @@ ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) - ;; FIXME: What does the next comment mean? Presumably it - ;; refers to the age-old implementation where cache vectors - ;; where cached resources? Also, the first thing UPDATE-DFUN - ;; does it SET-DFUN, so do we really need it here? - (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) (defmethod (setf class-name) (new-value class) diff --git a/version.lisp-expr b/version.lisp-expr index b04437b..ee6517c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.6.4" +"1.0.6.5"