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))
(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
(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
;; 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
(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
(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*)