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
(%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)))
\f
;;;; DEBUG-SOURCEs
#!-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)
(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)
;;;; (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)))
; (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
;;;
;;; 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
\f
(defun descriptor-sap (x)
(int-sap (get-lisp-obj-address x)))
+(defun nth-interrupt-context (n)
+ (declare (type (unsigned-byte 32) n)
+ (optimize (speed 3) (safety 0)))
+ (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
+ (+ sb!vm::thread-interrupt-contexts-offset n))
+ (* os-context-t)))
+
;;; Return the top frame of the control stack as it was before calling
;;; this function.
(defun top-frame ()
(/noshow0 "entering TOP-FRAME")
- (multiple-value-bind (fp pc) (%caller-frame-and-pc)
- (compute-calling-frame (descriptor-sap fp) pc nil)))
+ ;; check to see if we can get the context by calling
+ ;; nth-interrupt-context, otherwise use the (%caller-frame-and-pc
+ ;; vop).
+ (let ((context (nth-interrupt-context 0)))
+ (if (and context
+ (not (sb!alien:null-alien context)))
+ (compute-calling-frame
+ (int-sap (sb!vm:context-register context
+ sb!vm::cfp-offset))
+ (context-pc context) nil)
+ (multiple-value-bind (fp pc) (%caller-frame-and-pc)
+ (compute-calling-frame (descriptor-sap fp) pc nil)))))
;;; Flush all of the frames above FRAME, and renumber all the frames
;;; below FRAME.
(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
;;; 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))
(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))
(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))
(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))
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))
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
-(defun nth-interrupt-context (n)
- (declare (type (unsigned-byte 32) n)
- (optimize (speed 3) (safety 0)))
- (sb!alien:sap-alien (sb!vm::current-thread-offset-sap
- (+ sb!vm::thread-interrupt-contexts-offset n))
- (* os-context-t)))
-
#!+(or x86 x86-64)
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
;;; 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)))
(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
(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
(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
(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))))))))
\f
;;;; operations on DEBUG-BLOCKs
;;; 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))
(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)
(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*)
;; (There used to be more cases back before sbcl-0.7.0, when
;; we did special tricks to debug the IR1 interpreter.)
))
+
+\f
+;;;; 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)))
projects / sbcl.git / blobdiff