X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=accddcbca8f233db982e8ec2872e779bf40ddf26;hb=5a9b7fcee7cd5374010d7a5b05463b84abc35079;hp=733d26900af1631c22767545f4c1595457226c08;hpb=6987ae7ad3e3ab62b45403fc0bd58ce9c73e2e92;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 733d269..accddcb 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -705,9 +705,9 @@ (let ((fp (frame-pointer frame))) (when (control-stack-pointer-valid-p fp) #!+(or x86 x86-64) - (multiple-value-bind (ra ofp) (x86-call-context fp) + (multiple-value-bind (ra ofp) (x86-call-context fp) (and ra (compute-calling-frame ofp ra frame))) - #!-(or x86 x86-64) + #!-(or x86 x86-64) (compute-calling-frame #!-alpha (sap-ref-sap fp (* ocfp-save-offset @@ -725,16 +725,6 @@ ;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the ;;; standard save location offset on the stack. LOC is the saved ;;; SC-OFFSET describing the main location. -#!-(or x86 x86-64) -(defun get-context-value (frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-access-debug-var-slot pointer loc escaped) - (stack-ref pointer stack-slot)))) -#!+(or x86 x86-64) (defun get-context-value (frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -742,6 +732,9 @@ (escaped (compiled-frame-escaped frame))) (if escaped (sub-access-debug-var-slot pointer loc escaped) + #!-(or x86 x86-64) + (stack-ref pointer stack-slot) + #!+(or x86 x86-64) (ecase stack-slot (#.ocfp-save-offset (stack-ref pointer stack-slot)) @@ -749,17 +742,6 @@ (sap-ref-sap pointer (- (* (1+ stack-slot) sb!vm::n-word-bytes)))))))) -#!-(or x86 x86-64) -(defun (setf get-context-value) (value frame stack-slot loc) - (declare (type compiled-frame frame) (type unsigned-byte stack-slot) - (type sb!c:sc-offset loc)) - (let ((pointer (frame-pointer frame)) - (escaped (compiled-frame-escaped frame))) - (if escaped - (sub-set-debug-var-slot pointer loc value escaped) - (setf (stack-ref pointer stack-slot) value)))) - -#!+(or x86 x86-64) (defun (setf get-context-value) (value frame stack-slot loc) (declare (type compiled-frame frame) (type unsigned-byte stack-slot) (type sb!c:sc-offset loc)) @@ -767,6 +749,9 @@ (escaped (compiled-frame-escaped frame))) (if escaped (sub-set-debug-var-slot pointer loc value escaped) + #!-(or x86 x86-64) + (setf (stack-ref pointer stack-slot) value) + #!+(or x86 x86-64) (ecase stack-slot (#.ocfp-save-offset (setf (stack-ref pointer stack-slot) value)) @@ -838,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)) @@ -999,6 +985,7 @@ register." ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the ;;; undefined-function. +#!-(or x86 x86-64) (defun code-object-from-bits (bits) (declare (type (unsigned-byte 32) bits)) (let ((object (make-lisp-obj bits))) @@ -1006,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)))))))) ;;;; frame utilities @@ -3058,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)) @@ -3068,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) @@ -3141,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 @@ -3150,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 @@ -3179,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 @@ -3199,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*)