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

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 4021963..fbec1a2 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -526,11 +526,11 @@
     #!-stack-grows-downward-not-upward
     (and (sap< x (current-sp))
          (sap<= control-stack-start x)
-         (zerop (logand (sap-int x) #b11)))
+         (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))
     #!+stack-grows-downward-not-upward
     (and (sap>= x (current-sp))
          (sap> control-stack-end x)
-         (zerop (logand (sap-int x) #b11)))))
+         (zerop (logand (sap-int x) sb!vm:fixnum-tag-mask)))))
 
 (declaim (inline component-ptr-from-pc))
 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
@@ -654,12 +654,29 @@
 (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")
-  (multiple-value-bind (fp pc) (%caller-frame-and-pc)
-    (compute-calling-frame (descriptor-sap fp) pc nil)))
+  ;; 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)))))
 
 ;;; Flush all of the frames above FRAME, and renumber all the frames
 ;;; below FRAME.
@@ -861,13 +878,6 @@
                              (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))
@@ -1114,6 +1124,48 @@ register."
                  (sap-ref-32 catch
                              (* sb!vm:catch-block-previous-catch-slot
                                 sb!vm:n-word-bytes)))))))
+
+;;; Modify the value of the OLD-TAG catches in FRAME to NEW-TAG
+(defun replace-frame-catch-tag (frame old-tag new-tag)
+  (let ((catch (descriptor-sap sb!vm:*current-catch-block*))
+        (fp (frame-pointer frame)))
+    (loop until (zerop (sap-int catch))
+          do (when (sap= fp
+                         #!-alpha
+                         (sap-ref-sap catch
+                                      (* sb!vm:catch-block-current-cont-slot
+                                         sb!vm:n-word-bytes))
+                         #!+alpha
+                         (int-sap
+                          (sap-ref-32 catch
+                                      (* sb!vm:catch-block-current-cont-slot
+                                         sb!vm:n-word-bytes))))
+               (let ((current-tag
+                      #!-(or x86 x86-64)
+                      (stack-ref catch sb!vm:catch-block-tag-slot)
+                      #!+(or x86 x86-64)
+                      (make-lisp-obj
+                       (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                              sb!vm:n-word-bytes)))))
+                 (when (eq current-tag old-tag)
+                   #!-(or x86 x86-64)
+                   (setf (stack-ref catch sb!vm:catch-block-tag-slot) new-tag)
+                   #!+(or x86 x86-64)
+                   (setf (sap-ref-word catch (* sb!vm:catch-block-tag-slot
+                                                sb!vm:n-word-bytes))
+                         (get-lisp-obj-address new-tag)))))
+          do (setf catch
+                   #!-alpha
+                   (sap-ref-sap catch
+                                (* sb!vm:catch-block-previous-catch-slot
+                                   sb!vm:n-word-bytes))
+                   #!+alpha
+                   (int-sap
+                    (sap-ref-32 catch
+                                (* sb!vm:catch-block-previous-catch-slot
+                                   sb!vm:n-word-bytes)))))))
+
+
 
 ;;;; operations on DEBUG-FUNs