changes in sbcl-1.0.8 relative to sbcl-1.0.7:
* enhancement: closed over variables can be stack-allocated on x86 and
x86-64.
+ * bug fix: backtrace construction is now more careful when
+ making lisp-objects from pointers on the stack, to avoid creating
+ bogus objects that can be seen by the GC.
changes in sbcl-1.0.7 relative to sbcl-1.0.6:
* MOP improvement: support for user-defined subclasses of
"%LOG1P"
#!+long-float "%LONG-FLOAT"
"%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE"
- "%MAKE-RATIO" "%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1"
+ "%MAKE-RATIO" "%MAKE-LISP-OBJ"
+ "%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1"
"%MAP-TO-LIST-ARITY-1" "%MAP-TO-NIL-ON-SEQUENCE"
"%MAP-TO-NIL-ON-SIMPLE-VECTOR" "%MAP-TO-NIL-ON-VECTOR"
"%MASK-FIELD" "%NEGATE" "%POW" "%PUTHASH"
(type (unsigned-byte #.n-word-bits) words)
(type index length))
(handler-case
- ;; FIXME: Is WITHOUT-GCING enough to do lisp-side allocation
- ;; to static space, or should we have WITHOUT-INTERRUPTS here
- ;; as well?
+ ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
(without-gcing
(let* ((pointer *static-space-free-pointer*) ; in words
(free (* pointer n-word-bytes))
(unless (> static-space-end new-free)
(error 'simple-storage-condition
:format-control "Not enough memory left in static space to ~
- allocate vector."))
+ allocate vector."))
(store-word widetag
vector 0 other-pointer-lowtag)
(store-word (ash length word-shift)
vector vector-length-slot other-pointer-lowtag)
(store-word 0 new-free)
- (prog1
- (make-lisp-obj vector)
- (setf *static-space-free-pointer* new-pointer))))
+ (setf *static-space-free-pointer* new-pointer)
+ (%make-lisp-obj vector)))
(serious-condition (c)
;; unwind from WITHOUT-GCING
(error c))))
(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
(defun fun-code-header (fun) (fun-code-header fun))
(defun lra-code-header (lra) (lra-code-header lra))
-(defun make-lisp-obj (value) (make-lisp-obj value))
+(defun %make-lisp-obj (value) (%make-lisp-obj value))
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
(defun fun-word-offset (fun) (fun-word-offset fun))
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
+#!+(or x86 x86-64)
+(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
+ (pointer system-area-pointer))
+
(declaim (inline component-from-component-ptr))
(defun component-from-component-ptr (component-ptr)
(declare (type system-area-pointer component-ptr))
#!-(or x86 x86-64)
(defun code-object-from-bits (bits)
(declare (type (unsigned-byte 32) bits))
- (let ((object (make-lisp-obj bits)))
+ (let ((object (make-lisp-obj bits nil)))
(if (functionp object)
(or (fun-code-header object)
:undefined-function)
(compiled-debug-var-sc-offset debug-var))))))
;;; a helper function for working with possibly-invalid values:
-;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
+;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
;;;
;;; (Such values can arise in registers on machines with conservative
;;; GC, and might also arise in debug variable locations when
;;; those variables are invalid.)
-(defun make-valid-lisp-obj (val)
+(defun make-lisp-obj (val &optional (errorp t))
(if (or
;; fixnum
(zerop (logand val sb!vm:fixnum-tag-mask))
;; unbound marker
(= val sb!vm:unbound-marker-widetag)
;; pointer
- (and (logbitp 0 val)
- ;; Check that the pointer is valid. XXX Could do a better
- ;; job. FIXME: e.g. by calling out to an is_valid_pointer
- ;; routine in the C runtime support code
- (or (< sb!vm:read-only-space-start val
- (* sb!vm:*read-only-space-free-pointer*
- sb!vm:n-word-bytes))
- (< sb!vm:static-space-start val
- (* sb!vm:*static-space-free-pointer*
- sb!vm:n-word-bytes))
- (< (current-dynamic-space-start) val
- (sap-int (dynamic-space-free-pointer))))))
- (make-lisp-obj val)
- :invalid-object))
+ #!+(or x86 x86-64)
+ (not (zerop (valid-lisp-pointer-p (int-sap val))))
+ ;; FIXME: There is no fundamental reason not to use the above
+ ;; function on other platforms as well, but I didn't have
+ ;; others available while doing this. --NS 2007-06-21
+ #!-(or x86 x86-64)
+ (and (logbitp 0 val)
+ (or (< sb!vm:read-only-space-start val
+ (* sb!vm:*read-only-space-free-pointer*
+ sb!vm:n-word-bytes))
+ (< sb!vm:static-space-start val
+ (* sb!vm:*static-space-free-pointer*
+ sb!vm:n-word-bytes))
+ (< (current-dynamic-space-start) val
+ (sap-int (dynamic-space-free-pointer))))))
+ (values (%make-lisp-obj val) t)
+ (if errorp
+ (error "~S is not a valid argument to ~S"
+ val 'make-lisp-obj)
+ (values (make-unprintable-object (format nil "invalid object #x~X" val))
+ nil))))
#!-(or x86 x86-64)
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
#.sb!vm:descriptor-reg-sc-number
#!+rt #.sb!vm:word-pointer-reg-sc-number)
(sb!sys:without-gcing
- (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
-
+ (with-escaped-value (val)
+ (make-lisp-obj val nil))))
(#.sb!vm:character-reg-sc-number
(with-escaped-value (val)
(code-char val)))
((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
(without-gcing
(with-escaped-value (val)
- (make-valid-lisp-obj val))))
+ (make-lisp-obj val nil))))
(#.sb!vm:character-reg-sc-number
(with-escaped-value (val)
(code-char val)))
(defun handle-single-step-around-trap (context callee-register-offset)
;; Fetch the function / fdefn we're about to call from the
;; appropriate register.
- (let* ((callee (sb!kernel::make-lisp-obj
+ (let* ((callee (make-lisp-obj
(context-register context callee-register-offset)))
(step-info (single-step-info-from-context context)))
;; If there was not enough debug information available, there's no
(eq (room-info-kind info) :lowtag))
(let ((size (* cons-size n-word-bytes)))
(funcall fun
- (make-lisp-obj (logior (sap-int current)
+ (%make-lisp-obj (logior (sap-int current)
list-pointer-lowtag))
list-pointer-lowtag
size)
(setq current (sap+ current size))))
((eql header-widetag closure-header-widetag)
- (let* ((obj (make-lisp-obj (logior (sap-int current)
+ (let* ((obj (%make-lisp-obj (logior (sap-int current)
fun-pointer-lowtag)))
(size (round-to-dualword
(* (the fixnum (1+ (get-closure-length obj)))
(funcall fun obj header-widetag size)
(setq current (sap+ current size))))
((eq (room-info-kind info) :instance)
- (let* ((obj (make-lisp-obj
+ (let* ((obj (%make-lisp-obj
(logior (sap-int current) instance-pointer-lowtag)))
(size (round-to-dualword
(* (+ (%instance-length obj) 1) n-word-bytes))))
(aver (zerop (logand size lowtag-mask)))
(setq current (sap+ current size))))
(t
- (let* ((obj (make-lisp-obj
+ (let* ((obj (%make-lisp-obj
(logior (sap-int current) other-pointer-lowtag)))
(size (ecase (room-info-kind info)
(:fixed
(:translate fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
(defknown lra-code-header (t) t (movable flushable))
(defknown fun-code-header (t) t (movable flushable))
-(defknown make-lisp-obj (sb!vm:word) t (movable flushable))
+(defknown %make-lisp-obj (sb!vm:word) t (movable flushable))
(defknown get-lisp-obj-address (t) sb!vm:word (movable flushable))
(defknown fun-word-offset (function) index (movable flushable))
\f
(:translate fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(:translate sb!di::fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate sb!di::make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(:translate sb!di::fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate sb!di::make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(in-package "SB!VM")
-;;; (defknown di::current-sp () system-area-pointer (movable flushable))
-;;; (defknown di::current-fp () system-area-pointer (movable flushable))
-;;; (defknown di::stack-ref (system-area-pointer index) t (flushable))
-;;; (defknown di::%set-stack-ref (system-area-pointer index t) t (unsafe))
-;;; (defknown di::lra-code-header (t) t (movable flushable))
-;;; (defknown di::function-code-header (t) t (movable flushable))
-;;; (defknown di::make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
-;;; (defknown di::get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
-;;; (defknown di::function-word-offset (function) index (movable flushable))
-
(define-vop (debug-cur-sp)
(:translate current-sp)
(:policy :fast-safe)
(:translate fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)))
(:translate sb!di::fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate sb!di::make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg unsigned-stack) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)
(:translate sb!di::fun-code-header)
(:variant fun-pointer-lowtag))
-(define-vop (make-lisp-obj)
+(define-vop (%make-lisp-obj)
(:policy :fast-safe)
- (:translate sb!di::make-lisp-obj)
+ (:translate %make-lisp-obj)
(:args (value :scs (unsigned-reg unsigned-stack) :target result))
(:arg-types unsigned-num)
(:results (result :scs (descriptor-reg)
#if defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64)
-/* Is there any possibility that pointer is a valid Lisp object
- * reference, and/or something else (e.g. subroutine call return
- * address) which should prevent us from moving the referred-to thing?
- * This is called from preserve_pointers() */
+/* Helper for valid_lisp_pointer_p and
+ * possibly_valid_dynamic_space_pointer.
+ *
+ * pointer is the pointer to validate, and start_addr is the address
+ * of the enclosing object.
+ */
static int
-possibly_valid_dynamic_space_pointer(lispobj *pointer)
+looks_like_valid_lisp_pointer_p(lispobj *pointer, lispobj *start_addr)
{
- lispobj *start_addr;
-
- /* Find the object start address. */
- if ((start_addr = search_dynamic_space(pointer)) == NULL) {
- return 0;
- }
-
/* We need to allow raw pointers into Code objects for return
* addresses. This will also pick up pointers to functions in code
* objects. */
- if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG) {
+ if (widetag_of(*start_addr) == CODE_HEADER_WIDETAG)
/* XXX could do some further checks here */
return 1;
- }
- /* If it's not a return address then it needs to be a valid Lisp
- * pointer. */
if (!is_lisp_pointer((lispobj)pointer)) {
return 0;
}
/* Check that the object pointed to is consistent with the pointer
- * low tag.
- */
+ * low tag. */
switch (lowtag_of((lispobj)pointer)) {
case FUN_POINTER_LOWTAG:
/* Start_addr should be the enclosing code object, or a closure
return 1;
}
+/* Used by the debugger to validate possibly bogus pointers before
+ * calling MAKE-LISP-OBJ on them.
+ *
+ * FIXME: We would like to make this perfect, because if the debugger
+ * constructs a reference to a bugs lisp object, and it ends up in a
+ * location scavenged by the GC all hell breaks loose.
+ *
+ * Whereas possibly_valid_dynamic_space_pointer has to be conservative
+ * and return true for all valid pointers, this could actually be eager
+ * and lie about a few pointers without bad results... but that should
+ * be reflected in the name.
+ */
+int
+valid_lisp_pointer_p(lispobj *pointer)
+{
+ lispobj *start;
+ if (((start=search_dynamic_space(pointer))!=NULL) ||
+ ((start=search_static_space(pointer))!=NULL) ||
+ ((start=search_read_only_space(pointer))!=NULL))
+ return looks_like_valid_lisp_pointer_p(pointer, start);
+ else
+ return 0;
+}
+
+/* Is there any possibility that pointer is a valid Lisp object
+ * reference, and/or something else (e.g. subroutine call return
+ * address) which should prevent us from moving the referred-to thing?
+ * This is called from preserve_pointers() */
+static int
+possibly_valid_dynamic_space_pointer(lispobj *pointer)
+{
+ lispobj *start_addr;
+
+ /* Find the object start address. */
+ if ((start_addr = search_dynamic_space(pointer)) == NULL) {
+ return 0;
+ }
+
+ return looks_like_valid_lisp_pointer_p(pointer, start_addr);
+}
+
/* Adjust large bignum and vector objects. This will adjust the
* allocated region if the size has shrunk, and move unboxed objects
* into unboxed pages. The pages are not promoted here, and the
;;; 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.7.1"
+"1.0.7.2"
projects / sbcl.git / commitdiff