(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))
(defun descriptor-sap (x)
(int-sap (get-lisp-obj-address x)))
-(defun nth-interrupt-context (n)
- (declare (type (unsigned-byte 32) n)
- (optimize (speed 3) (safety 0)))
- (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
- (+ sb!vm::thread-interrupt-contexts-offset n))
- (* os-context-t)))
-
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
(/noshow0 "entering TOP-FRAME")
- ;; check to see if we can get the context by calling
- ;; nth-interrupt-context, otherwise use the (%caller-frame-and-pc
- ;; vop).
- (let ((context (nth-interrupt-context 0)))
- (if (and context
- (not (sb!alien:null-alien context)))
- (compute-calling-frame
- (int-sap (sb!vm:context-register context
- sb!vm::cfp-offset))
- (context-pc context) nil)
- (multiple-value-bind (fp pc) (%caller-frame-and-pc)
- (compute-calling-frame (descriptor-sap fp) pc nil)))))
+ (multiple-value-bind (fp pc) (%caller-frame-and-pc)
+ (compute-calling-frame (descriptor-sap fp) pc nil)))
;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
#!-(or x86 x86-64)
(defun compute-calling-frame (caller lra up-frame)
(declare (type system-area-pointer caller))
+ (/noshow0 "entering COMPUTE-CALLING-FRAME")
(when (control-stack-pointer-valid-p caller)
+ (/noshow0 "in WHEN")
(multiple-value-bind (code pc-offset escaped)
(if lra
(multiple-value-bind (word-offset code)
"bogus stack frame"))
(t
(debug-fun-from-pc code pc-offset)))))
+ (/noshow0 "returning MAKE-COMPILED-FRAME from COMPUTE-CALLING-FRAME")
(make-compiled-frame caller up-frame d-fun
(code-location-from-pc d-fun pc-offset
escaped)
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
+(defun nth-interrupt-context (n)
+ (declare (type (unsigned-byte 32) n)
+ (optimize (speed 3) (safety 0)))
+ (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
+ (+ sb!vm::thread-interrupt-contexts-offset n))
+ (* os-context-t)))
+
#!+(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
#!-(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
+ (/noshow0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
+ (/noshow0 "at head of WITH-ALIEN")
(let ((scp (nth-interrupt-context index)))
+ (/noshow0 "got SCP")
(when (= (sap-int frame-pointer)
(sb!vm:context-register scp sb!vm::cfp-offset))
(without-gcing
+ (/noshow0 "in WITHOUT-GCING")
(let ((code (code-object-from-bits
(sb!vm:context-register scp sb!vm::code-offset))))
+ (/noshow0 "got CODE")
(when (symbolp code)
(return (values code 0 scp)))
(let* ((code-header-len (* (get-header-data code)
;; pc-offset to 0 to keep the backtrace from
;; exploding.
(setf pc-offset 0)))))
+ (/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(if (eq (%code-debug-info code) :bogus-lra)
(let ((real-lra (code-header-ref code
#!-(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)))
;;; or replace the function that's about to be called with a wrapper
;;; which will signal the condition.
-(defun handle-single-step-trap (context-sap kind callee-register-offset)
- (let ((context (sb!alien:sap-alien context-sap (* os-context-t))))
+(defun handle-single-step-trap (kind callee-register-offset)
+ (let ((context (nth-interrupt-context (1- *free-interrupt-context-index*))))
;; The following calls must get tail-call eliminated for
;; *STEP-FRAME* to get set correctly on non-x86.
(if (= kind single-step-before-trap)
(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
projects / sbcl.git / blobdiff