X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=4021963a518168cb3edb5d719637ef3ffda2425a;hb=3c7a9b188472ae8381e50a3dfbed1c6631219893;hp=9d1097f23252f40c5991e519ca50491580b2b3b1;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 9d1097f..4021963 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -466,12 +466,12 @@ str))) (defstruct (compiled-code-location - (:include code-location) - (:constructor make-known-code-location - (pc debug-fun %tlf-offset %form-number - %live-set kind &aux (%unknown-p nil))) - (:constructor make-compiled-code-location (pc debug-fun)) - (:copier nil)) + (:include code-location) + (:constructor make-known-code-location + (pc debug-fun %tlf-offset %form-number + %live-set kind step-info &aux (%unknown-p nil))) + (:constructor make-compiled-code-location (pc debug-fun)) + (:copier nil)) ;; an index into DEBUG-FUN's component slot (pc nil :type index) ;; a bit-vector indexed by a variable's position in @@ -480,7 +480,8 @@ (%live-set :unparsed :type (or simple-bit-vector (member :unparsed))) ;; (unexported) To see SB!C::LOCATION-KIND, do ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND). - (kind :unparsed :type (or (member :unparsed) sb!c::location-kind))) + (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)) + (step-info :unparsed :type (or (member :unparsed :foo) simple-string))) ;;;; DEBUG-SOURCEs @@ -531,9 +532,11 @@ (sap> control-stack-end x) (zerop (logand (sap-int x) #b11))))) +(declaim (inline component-ptr-from-pc)) (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) (pc system-area-pointer)) +(declaim (inline component-from-component-ptr)) (defun component-from-component-ptr (component-ptr) (declare (type system-area-pointer component-ptr)) (make-lisp-obj (logior (sap-int component-ptr) @@ -541,9 +544,6 @@ ;;;; (OR X86 X86-64) support -#!+(or x86 x86-64) -(progn - (defun compute-lra-data-from-pc (pc) (declare (type system-area-pointer pc)) (let ((component-ptr (component-ptr-from-pc pc))) @@ -557,6 +557,9 @@ ; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset) (values pc-offset code))))) +#!+(or x86 x86-64) +(progn + (defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset) ;;; Check for a valid return address - it could be any valid C/Lisp @@ -584,74 +587,64 @@ ;;; ;;; XXX Should handle interrupted frames, both Lisp and C. At present ;;; it manages to find a fp trail, see linux hack below. -(defun x86-call-context (fp &key (depth 0)) - (declare (type system-area-pointer fp) - (fixnum depth)) -;; (format t "*CC ~S ~S~%" fp depth) - (cond - ((not (control-stack-pointer-valid-p fp)) - #+nil (format t "debug invalid fp ~S~%" fp) - nil) - (t - ;; Check the two possible frame pointers. - (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) - sb!vm::n-word-bytes)))) - (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) - sb!vm::n-word-bytes)))) - (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) - (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) - #+nil (format t " lisp-ocfp=~S~% lisp-ra=~S~% c-ocfp=~S~% c-ra=~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - (cond ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra) - (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) - (ra-pointer-valid-p c-ra)) - #+nil (format t - "*C Both valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra) - ;; Look forward another step to check their validity. - (let ((lisp-path-fp (x86-call-context lisp-ocfp - :depth (1+ depth))) - (c-path-fp (x86-call-context c-ocfp :depth (1+ depth)))) - (cond ((and lisp-path-fp c-path-fp) - ;; Both still seem valid - choose the lisp frame. - #+nil (when (zerop depth) - (format t - "debug: both still valid ~S ~S ~S ~S~%" - lisp-ocfp lisp-ra c-ocfp c-ra)) - #!+freebsd - (if (sap> lisp-ocfp c-ocfp) - (values lisp-ra lisp-ocfp) - (values c-ra c-ocfp)) - #!-freebsd - (values lisp-ra lisp-ocfp)) - (lisp-path-fp - ;; The lisp convention is looking good. - #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) - (values lisp-ra lisp-ocfp)) - (c-path-fp - ;; The C convention is looking good. - #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) - (values c-ra c-ocfp)) - (t - ;; Neither seems right? - #+nil (format t "debug: no valid2 fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))) - ((and (sap> lisp-ocfp fp) (control-stack-pointer-valid-p lisp-ocfp) - (ra-pointer-valid-p lisp-ra)) - ;; The lisp convention is looking good. - #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra) - (values lisp-ra lisp-ocfp)) - ((and (sap> c-ocfp fp) (control-stack-pointer-valid-p c-ocfp) - #!-linux (ra-pointer-valid-p c-ra)) - ;; The C convention is looking good. - #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra) - (values c-ra c-ocfp)) - (t - #+nil (format t "debug: no valid fp found ~S ~S~%" - lisp-ocfp c-ocfp) - nil)))))) +(declaim (maybe-inline x86-call-context)) +(defun x86-call-context (fp) + (declare (type system-area-pointer fp)) + (labels ((fail () + (values nil + (int-sap 0) + (int-sap 0))) + (handle (fp) + (cond + ((not (control-stack-pointer-valid-p fp)) + (fail)) + (t + ;; Check the two possible frame pointers. + (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ ocfp-save-offset) + sb!vm::n-word-bytes)))) + (lisp-ra (sap-ref-sap fp (- (* (1+ return-pc-save-offset) + sb!vm::n-word-bytes)))) + (c-ocfp (sap-ref-sap fp (* 0 sb!vm:n-word-bytes))) + (c-ra (sap-ref-sap fp (* 1 sb!vm:n-word-bytes)))) + (cond ((and (sap> lisp-ocfp fp) + (control-stack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra) + (sap> c-ocfp fp) + (control-stack-pointer-valid-p c-ocfp) + (ra-pointer-valid-p c-ra)) + ;; Look forward another step to check their validity. + (let ((lisp-ok (handle lisp-ocfp)) + (c-ok (handle c-ocfp))) + (cond ((and lisp-ok c-ok) + ;; Both still seem valid - choose the lisp frame. + #!+freebsd + (if (sap> lisp-ocfp c-ocfp) + (values t lisp-ra lisp-ocfp) + (values t c-ra c-ocfp)) + #!-freebsd + (values t lisp-ra lisp-ocfp)) + (lisp-ok + ;; The lisp convention is looking good. + (values t lisp-ra lisp-ocfp)) + (c-ok + ;; The C convention is looking good. + (values t c-ra c-ocfp)) + (t + ;; Neither seems right? + (fail))))) + ((and (sap> lisp-ocfp fp) + (control-stack-pointer-valid-p lisp-ocfp) + (ra-pointer-valid-p lisp-ra)) + ;; The lisp convention is looking good. + (values t lisp-ra lisp-ocfp)) + ((and (sap> c-ocfp fp) + (control-stack-pointer-valid-p c-ocfp) + #!-linux (ra-pointer-valid-p c-ra)) + ;; The C convention is looking good. + (values t c-ra c-ocfp)) + (t + (fail)))))))) + (handle fp))) ) ; #+x86 PROGN @@ -705,9 +698,10 @@ (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) - (and ra (compute-calling-frame ofp ra frame))) - #!-(or x86 x86-64) + (multiple-value-bind (ok ra ofp) (x86-call-context fp) + (and ok + (compute-calling-frame ofp ra frame))) + #!-(or x86 x86-64) (compute-calling-frame #!-alpha (sap-ref-sap fp (* ocfp-save-offset @@ -725,16 +719,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 +726,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 +736,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 +743,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 +817,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)) @@ -947,11 +927,6 @@ (- (get-lisp-obj-address code) sb!vm:other-pointer-lowtag) code-header-len))) - ;; Check to see whether we were executing in a branch - ;; delay slot. - #!+(or pmax sgi) ; pmax only (and broken anyway) - (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause)) - (incf pc-offset sb!vm:n-word-bytes)) (let ((code-size (* (code-header-ref code sb!vm:code-code-size-slot) sb!vm:n-word-bytes))) @@ -1004,6 +979,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))) @@ -1011,14 +987,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 @@ -1563,10 +1539,12 @@ register." (sb!c:read-var-integer blocks i))) (form-number (sb!c:read-var-integer blocks i)) (live-set (sb!c:read-packed-bit-vector - live-set-len blocks i))) + live-set-len blocks i)) + (step-info (sb!c:read-var-string blocks i))) (vector-push-extend (make-known-code-location pc debug-fun tlf-offset - form-number live-set kind) + form-number live-set kind + step-info) locations-buffer) (setf last-pc pc)))) (block (make-compiled-debug-block @@ -1884,6 +1862,8 @@ register." (compiled-code-location-%live-set loc)) (setf (compiled-code-location-kind code-location) (compiled-code-location-kind loc)) + (setf (compiled-code-location-step-info code-location) + (compiled-code-location-step-info loc)) (return-from fill-in-code-location t)))))))) ;;;; operations on DEBUG-BLOCKs @@ -3063,7 +3043,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)) @@ -3073,11 +3053,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) @@ -3146,7 +3126,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 @@ -3155,24 +3135,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 @@ -3184,6 +3162,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 @@ -3204,10 +3192,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*) @@ -3307,3 +3292,137 @@ register." ;; (There used to be more cases back before sbcl-0.7.0, when ;; we did special tricks to debug the IR1 interpreter.) )) + + +;;;; Single-stepping + +;;; The single-stepper works by inserting conditional trap instructions +;;; into the generated code (see src/compiler/*/call.lisp), currently: +;;; +;;; 1) Before the code generated for a function call that was +;;; translated to a VOP +;;; 2) Just before the call instruction for a full call +;;; +;;; In both cases, the trap will only be executed if stepping has been +;;; enabled, in which case it'll ultimately be handled by +;;; HANDLE-SINGLE-STEP-TRAP, which will either signal a stepping condition, +;;; 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)))) + ;; The following calls must get tail-call eliminated for + ;; *STEP-FRAME* to get set correctly on non-x86. + (if (= kind single-step-before-trap) + (handle-single-step-before-trap context) + (handle-single-step-around-trap context callee-register-offset)))) + +(defvar *step-frame* nil) + +(defun handle-single-step-before-trap (context) + (let ((step-info (single-step-info-from-context context))) + ;; If there was not enough debug information available, there's no + ;; sense in signaling the condition. + (when step-info + (let ((*step-frame* + #+(or x86 x86-64) + (signal-context-frame (sb!alien::alien-sap context)) + #-(or x86 x86-64) + ;; KLUDGE: Use the first non-foreign frame as the + ;; *STACK-TOP-HINT*. Getting the frame from the signal + ;; context as on x86 would be cleaner, but + ;; SIGNAL-CONTEXT-FRAME doesn't seem seem to work at all + ;; on non-x86. + (loop with frame = (frame-down (top-frame)) + while frame + for dfun = (frame-debug-fun frame) + do (when (typep dfun 'compiled-debug-fun) + (return frame)) + do (setf frame (frame-down frame))))) + (sb!impl::step-form step-info + ;; We could theoretically store information in + ;; the debug-info about to determine the + ;; arguments here, but for now let's just pass + ;; on it. + :unknown))))) + +;;; This function will replace the fdefn / function that was in the +;;; register at CALLEE-REGISTER-OFFSET with a wrapper function. To +;;; ensure that the full call will use the wrapper instead of the +;;; original, conditional trap must be emitted before the fdefn / +;;; function is converted into a raw address. +(defun handle-single-step-around-trap (context callee-register-offset) + ;; Fetch the function / fdefn we're about to call from the + ;; appropriate register. + (let* ((callee (sb!kernel::make-lisp-obj + (context-register context callee-register-offset))) + (step-info (single-step-info-from-context context))) + ;; If there was not enough debug information available, there's no + ;; sense in signaling the condition. + (unless step-info + (return-from handle-single-step-around-trap)) + (let* ((fun (lambda (&rest args) + (flet ((call () + (apply (typecase callee + (fdefn (fdefn-fun callee)) + (function callee)) + args))) + ;; Signal a step condition + (let* ((step-in + (let ((*step-frame* (frame-down (top-frame)))) + (sb!impl::step-form step-info args)))) + ;; And proceed based on its return value. + (if step-in + ;; STEP-INTO was selected. Use *STEP-OUT* to + ;; let the stepper know that selecting the + ;; STEP-OUT restart is valid inside this + (let ((sb!impl::*step-out* :maybe)) + ;; Pass the return values of the call to + ;; STEP-VALUES, which will signal a + ;; condition with them in the VALUES slot. + (unwind-protect + (multiple-value-call #'sb!impl::step-values + step-info + (call)) + ;; If the user selected the STEP-OUT + ;; restart during the call, resume + ;; stepping + (when (eq sb!impl::*step-out* t) + (sb!impl::enable-stepping)))) + ;; STEP-NEXT / CONTINUE / OUT selected: + ;; Disable the stepper for the duration of + ;; the call. + (sb!impl::with-stepping-disabled + (call))))))) + (new-callee (etypecase callee + (fdefn + (let ((fdefn (make-fdefn (gensym)))) + (setf (fdefn-fun fdefn) fun) + fdefn)) + (function fun)))) + ;; And then store the wrapper in the same place. + (setf (context-register context callee-register-offset) + (get-lisp-obj-address new-callee))))) + +;;; Given a signal context, fetch the step-info that's been stored in +;;; the debug info at the trap point. +(defun single-step-info-from-context (context) + (multiple-value-bind (pc-offset code) + (compute-lra-data-from-pc (context-pc context)) + (let* ((debug-fun (debug-fun-from-pc code pc-offset)) + (location (code-location-from-pc debug-fun + pc-offset + nil))) + (handler-case + (progn + (fill-in-code-location location) + (code-location-debug-source location) + (compiled-code-location-step-info location)) + (debug-condition () + nil))))) + +;;; Return the frame that triggered a single-step condition. Used to +;;; provide a *STACK-TOP-HINT*. +(defun find-stepped-frame () + (or *step-frame* + (top-frame)))