1.0.5.39: sb-sprof call counting

[sbcl.git] / src / code / debug-int.lisp

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 4021963..0366b5b 100644 (file)
--- 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)
@@ -1114,6 +1114,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)))))))
+
+
 \f
 ;;;; operations on DEBUG-FUNs
 
@@ -3309,8 +3351,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)