X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=c714d28cbedbeb675603c49a44bcca32bf172361;hb=c1aa8b6b5b870f21bc8c81da85708e9d71d4eb93;hp=fbec1a2fe3541e9be66f209d0ecab8c3043dfffc;hpb=f59d43f28fb757db168e46399b7c8ab04cc6620b;p=sbcl.git

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index fbec1a2..c714d28 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -510,7 +510,7 @@
 (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))
 
@@ -536,6 +536,10 @@
 (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))
@@ -654,29 +658,12 @@
 (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.
@@ -793,7 +780,9 @@
 #!-(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)
@@ -829,6 +818,7 @@
                            "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)
@@ -878,6 +868,13 @@
                              (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))
@@ -921,13 +918,18 @@
 #!-(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)
@@ -964,6 +966,7 @@
                      ;; 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
@@ -992,7 +995,7 @@ register."
 #!-(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)
@@ -2000,12 +2003,12 @@ register."
            (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))
@@ -2018,20 +2021,27 @@ register."
        ;; 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)
@@ -2067,8 +2077,8 @@ register."
         #.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)))
@@ -2203,7 +2213,7 @@ register."
       ((#.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)))
@@ -3361,8 +3371,8 @@ register."
 ;;; 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)
@@ -3406,7 +3416,7 @@ register."
 (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