0.9.11.19:

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

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 66f2c87..accddcb 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -823,6 +823,7 @@
                                                         escaped)
                                  (if up-frame (1+ (frame-number up-frame)) 0)
                                  escaped))))))
+
 #!+(or x86 x86-64)
 (defun compute-calling-frame (caller ra up-frame)
   (declare (type system-area-pointer caller ra))
@@ -992,14 +993,14 @@ register."
         (or (fun-code-header object)
             :undefined-function)
         (let ((lowtag (lowtag-of object)))
-          (if (= lowtag sb!vm:other-pointer-lowtag)
-              (let ((widetag (widetag-of object)))
-                (cond ((= widetag sb!vm:code-header-widetag)
-                       object)
-                      ((= widetag sb!vm:return-pc-header-widetag)
-                       (lra-code-header object))
-                      (t
-                       nil))))))))
+          (when (= lowtag sb!vm:other-pointer-lowtag)
+            (let ((widetag (widetag-of object)))
+              (cond ((= widetag sb!vm:code-header-widetag)
+                     object)
+                    ((= widetag sb!vm:return-pc-header-widetag)
+                     (lra-code-header object))
+                    (t
+                     nil))))))))
 \f
 ;;;; frame utilities
 
@@ -3044,7 +3045,7 @@ register."
 ;;; returns the overwritten bits. You must call this in a context in
 ;;; which GC is disabled, so that Lisp doesn't move objects around
 ;;; that C is pointing to.
-(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-long
+(sb!alien:define-alien-routine "breakpoint_install" sb!alien:unsigned-int
   (code-obj sb!alien:unsigned-long)
   (pc-offset sb!alien:int))
 
@@ -3054,11 +3055,11 @@ register."
 (sb!alien:define-alien-routine "breakpoint_remove" sb!alien:void
   (code-obj sb!alien:unsigned-long)
   (pc-offset sb!alien:int)
-  (old-inst sb!alien:unsigned-long))
+  (old-inst sb!alien:unsigned-int))
 
 (sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!alien:void
   (scp (* os-context-t))
-  (orig-inst sb!alien:unsigned-long))
+  (orig-inst sb!alien:unsigned-int))
 
 ;;;; breakpoint handlers (layer between C and exported interface)
 
@@ -3127,7 +3128,7 @@ register."
   (unless (member data *executing-breakpoint-hooks*)
     (let ((*executing-breakpoint-hooks* (cons data
                                               *executing-breakpoint-hooks*)))
-      (invoke-breakpoint-hooks breakpoints component offset)))
+      (invoke-breakpoint-hooks breakpoints signal-context)))
   ;; At this point breakpoints may not hold the same list as
   ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
   ;; a breakpoint deactivation. In fact, if all breakpoints were
@@ -3136,24 +3137,22 @@ register."
   ;; no more breakpoints active at this location, then the normal
   ;; instruction has been put back, and we do not need to
   ;; DO-DISPLACED-INST.
-  (let ((data (breakpoint-data component offset nil)))
-    (when (and data (breakpoint-data-breakpoints data))
-      ;; The breakpoint is still active, so we need to execute the
-      ;; displaced instruction and leave the breakpoint instruction
-      ;; behind. The best way to do this is different on each machine,
-      ;; so we just leave it up to the C code.
-      (breakpoint-do-displaced-inst signal-context
-                                    (breakpoint-data-instruction data))
-      ;; Some platforms have no usable sigreturn() call.  If your
-      ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
-      ;; it's polite to warn here
-      #!+(and sparc solaris)
-      (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
-
-(defun invoke-breakpoint-hooks (breakpoints component offset)
-  (let* ((debug-fun (debug-fun-from-pc component offset))
-         (frame (do ((f (top-frame) (frame-down f)))
-                    ((eq debug-fun (frame-debug-fun f)) f))))
+  (setf data (breakpoint-data component offset nil))
+  (when (and data (breakpoint-data-breakpoints data))
+    ;; The breakpoint is still active, so we need to execute the
+    ;; displaced instruction and leave the breakpoint instruction
+    ;; behind. The best way to do this is different on each machine,
+    ;; so we just leave it up to the C code.
+    (breakpoint-do-displaced-inst signal-context
+                                  (breakpoint-data-instruction data))
+    ;; Some platforms have no usable sigreturn() call.  If your
+    ;; implementation of arch_do_displaced_inst() _does_ sigreturn(),
+    ;; it's polite to warn here
+    #!+(and sparc solaris)
+    (error "BREAKPOINT-DO-DISPLACED-INST returned?")))
+
+(defun invoke-breakpoint-hooks (breakpoints signal-context)
+  (let* ((frame (signal-context-frame signal-context)))
     (dolist (bpt breakpoints)
       (funcall (breakpoint-hook-fun bpt)
                frame
@@ -3165,6 +3164,16 @@ register."
                    (breakpoint-unknown-return-partner bpt)
                    bpt)))))
 
+(defun signal-context-frame (signal-context)
+  (let* ((scp
+          (locally
+            (declare (optimize (inhibit-warnings 3)))
+            (sb!alien:sap-alien signal-context (* os-context-t))))
+         (cfp (int-sap (sb!vm:context-register scp sb!vm::cfp-offset))))
+    (compute-calling-frame cfp
+                           (sb!vm:context-pc scp)
+                           nil)))
+
 (defun handle-fun-end-breakpoint (offset component context)
   (let ((data (breakpoint-data component offset nil)))
     (unless data
@@ -3185,10 +3194,7 @@ register."
           (locally
             (declare (optimize (inhibit-warnings 3)))
             (sb!alien:sap-alien signal-context (* os-context-t))))
-         (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
-                     (f (top-frame) (frame-down f)))
-                    ((= cfp (sap-int (frame-pointer f))) f)
-                  (declare (type (unsigned-byte #.sb!vm:n-word-bits) cfp))))
+         (frame (signal-context-frame signal-context))
          (component (breakpoint-data-component data))
          (cookie (gethash component *fun-end-cookies*)))
     (remhash component *fun-end-cookies*)