current frame, if this frame was compiled with a sufficiently high
DEBUG optimization quality.
+ RESTART-FRAME
+ Restart execution of the current frame, if this frame is for a
+ global function which was compiled with a sufficiently high
+ DEBUG optimization quality.
+
SLURP
Discard all pending input on *STANDARD-INPUT*. (This can be
useful when the debugger was invoked to handle an error in
\f
;;;; BACKTRACE
+(defun map-backtrace (thunk &key (start 0) (count most-positive-fixnum))
+ (loop
+ with result = nil
+ for index upfrom 0
+ for frame = (if *in-the-debugger*
+ *current-frame*
+ (sb!di:top-frame))
+ then (sb!di:frame-down frame)
+ until (null frame)
+ when (<= start index) do
+ (if (minusp (decf count))
+ (return result)
+ (setf result (funcall thunk frame)))
+ finally (return result)))
+
(defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
#!+sb-doc
"Show a listing of the call stack going down from the current frame.
In the debugger, the current frame is indicated by the prompt. COUNT
is how many frames to show."
(fresh-line stream)
- (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
- (sb!di:frame-down frame))
- (count count (1- count)))
- ((or (null frame) (zerop count)))
- (print-frame-call frame stream :number t))
+ (map-backtrace (lambda (frame)
+ (print-frame-call frame stream :number t))
+ :count count)
(fresh-line stream)
(values))
(defun backtrace-as-list (&optional (count most-positive-fixnum))
- #!+sb-doc "Return a list representing the current BACKTRACE."
- (do ((reversed-result nil)
- (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
- (sb!di:frame-down frame))
- (count count (1- count)))
- ((or (null frame) (zerop count))
- (nreverse reversed-result))
- (push (frame-call-as-list frame) reversed-result)))
+ #!+sb-doc
+ "Return a list representing the current BACKTRACE.
+
+Objects in the backtrace with dynamic-extent allocation by the current
+thread are represented by substitutes to avoid references to them from
+leaking outside their legal extent."
+ (let ((reversed-result (list)))
+ (map-backtrace (lambda (frame)
+ (let ((frame-list (frame-call-as-list frame)))
+ (if (listp (cdr frame-list))
+ (push (mapcar #'replace-dynamic-extent-object frame-list)
+ reversed-result)
+ (push frame-list reversed-result))))
+ :count count)
+ (nreverse reversed-result)))
(defun frame-call-as-list (frame)
(multiple-value-bind (name args) (frame-call frame)
(cons name args)))
+
+(defun replace-dynamic-extent-object (obj)
+ (if (stack-allocated-p obj)
+ (make-unprintable-object
+ (handler-case
+ (format nil "dynamic-extent: ~S" obj)
+ (error ()
+ "error printing dynamic-extent object")))
+ obj))
+
+(defun stack-allocated-p (obj)
+ "Returns T if OBJ is allocated on the stack of the current
+thread, NIL otherwise."
+ (with-pinned-objects (obj)
+ (let ((sap (int-sap (get-lisp-obj-address obj))))
+ (when (sb!vm:control-stack-pointer-valid-p sap nil)
+ t))))
\f
;;;; frame printing
optional
rest
keyword
+ more
deleted)
`(etypecase ,element
(sb!di:debug-var
(ecase (car ,element)
(:optional ,@optional)
(:rest ,@rest)
- (:keyword ,@keyword)))
+ (:keyword ,@keyword)
+ (:more ,@more)))
(symbol
(aver (eq ,element :deleted))
,@deleted)))
) ; EVAL-WHEN
;;; Extract the function argument values for a debug frame.
+(defun map-frame-args (thunk frame)
+ (let ((debug-fun (sb!di:frame-debug-fun frame)))
+ (dolist (element (sb!di:debug-fun-lambda-list debug-fun))
+ (funcall thunk element))))
+
(defun frame-args-as-list (frame)
- (let ((debug-fun (sb!di:frame-debug-fun frame))
- (loc (sb!di:frame-code-location frame))
- (reversed-result nil))
- (handler-case
- (progn
- (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
- (lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) reversed-result))
- :optional ((push (frame-call-arg (second ele) loc frame)
- reversed-result))
- :keyword ((push (second ele) reversed-result)
- (push (frame-call-arg (third ele) loc frame)
- reversed-result))
- :deleted ((push (frame-call-arg ele loc frame) reversed-result))
- :rest ((lambda-var-dispatch (second ele) loc
- nil
- (progn
- (setf reversed-result
- (append (reverse (sb!di:debug-var-value
- (second ele) frame))
- reversed-result))
- (return))
- (push (make-unprintable-object
- "unavailable &REST argument")
- reversed-result)))))
- ;; As long as we do an ordinary return (as opposed to SIGNALing
- ;; a CONDITION) from the DOLIST above:
- (nreverse reversed-result))
- (sb!di:lambda-list-unavailable
- ()
- (make-unprintable-object "unavailable lambda list")))))
-(legal-fun-name-p '(lambda ()))
+ (handler-case
+ (let ((location (sb!di:frame-code-location frame))
+ (reversed-result nil))
+ (block enumerating
+ (map-frame-args
+ (lambda (element)
+ (lambda-list-element-dispatch element
+ :required ((push (frame-call-arg element location frame) reversed-result))
+ :optional ((push (frame-call-arg (second element) location frame)
+ reversed-result))
+ :keyword ((push (second element) reversed-result)
+ (push (frame-call-arg (third element) location frame)
+ reversed-result))
+ :deleted ((push (frame-call-arg element location frame) reversed-result))
+ :rest ((lambda-var-dispatch (second element) location
+ nil
+ (let ((rest (sb!di:debug-var-value (second element) frame)))
+ (if (listp rest)
+ (setf reversed-result (append (reverse rest) reversed-result))
+ (push (make-unprintable-object "unavailable &REST argument")
+ reversed-result))
+ (return-from enumerating))
+ (push (make-unprintable-object
+ "unavailable &REST argument")
+ reversed-result)))
+ :more ((lambda-var-dispatch (second element) location
+ nil
+ (let ((context (sb!di:debug-var-value (second element) frame))
+ (count (sb!di:debug-var-value (third element) frame)))
+ (setf reversed-result
+ (append (reverse
+ (multiple-value-list
+ (sb!c::%more-arg-values context 0 count)))
+ reversed-result))
+ (return-from enumerating))
+ (push (make-unprintable-object "unavailable &MORE argument")
+ reversed-result)))))
+ frame))
+ (nreverse reversed-result))
+ (sb!di:lambda-list-unavailable ()
+ (make-unprintable-object "unavailable lambda list"))))
+
(defvar *show-entry-point-details* nil)
(defun clean-xep (name args)
;; &AUX-BINDINGS appear in backtraces, so they are
;; left alone for now. --NS 2005-02-28
(case (first name)
+ ((eval)
+ ;; The name of an evaluator thunk contains
+ ;; the source context -- but that makes for a
+ ;; confusing frame name, since it can look like an
+ ;; EVAL call with a bogus argument.
+ (values '#:eval-thunk nil))
((sb!c::xep sb!c::tl-xep)
(clean-xep name args))
((sb!c::&more-processor)
(multiple-value-bind (name args)
(clean-name-and-args (sb!di:debug-fun-name debug-fun)
(frame-args-as-list frame))
- (values name args
- (when *show-entry-point-details*
- (sb!di:debug-fun-kind debug-fun)))))))
+ (values name args (sb!di:debug-fun-kind debug-fun))))))
(defun ensure-printable-object (object)
(handler-case
;; If we hit a &REST arg, then print as many of the values as
;; possible, punting the loop over lambda-list variables since any
;; other arguments will be in the &REST arg's list of values.
- (let ((args (ensure-printable-object args)))
- (if (listp args)
- (format stream "~{ ~_~S~}" args)
- (format stream " ~S" args))))
+ (let ((print-args (ensure-printable-object args))
+ ;; Special case *PRINT-PRETTY* for eval frames: if
+ ;; *PRINT-LINES* is 1, turn off pretty-printing.
+ (*print-pretty*
+ (if (and (eql 1 *print-lines*)
+ (member name '(eval simple-eval-in-lexenv)))
+ nil
+ *print-pretty*)))
+ (if (listp print-args)
+ (format stream "~{ ~_~S~}" print-args)
+ (format stream " ~S" print-args))))
(when kind
(format stream "[~S]" kind))))
(when (>= verbosity 2)
(nreverse (mapcar #'cdr *debug-print-variable-alist*))
(apply fun rest)))))))
+;;; This function is not inlined so it shows up in the backtrace; that
+;;; can be rather handy when one has to debug the interplay between
+;;; *INVOKE-DEBUGGER-HOOK* and *DEBUGGER-HOOK*.
+(declaim (notinline run-hook))
+(defun run-hook (variable condition)
+ (let ((old-hook (symbol-value variable)))
+ (when old-hook
+ (progv (list variable) (list nil)
+ (funcall old-hook condition old-hook)))))
+
(defun invoke-debugger (condition)
#!+sb-doc
"Enter the debugger."
;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
;; called when the debugger is disabled
- (let ((old-hook *invoke-debugger-hook*))
- (when old-hook
- (let ((*invoke-debugger-hook* nil))
- (funcall old-hook condition old-hook))))
- (let ((old-hook *debugger-hook*))
- (when old-hook
- (let ((*debugger-hook* nil))
- (funcall old-hook condition old-hook))))
+ (run-hook '*invoke-debugger-hook* condition)
+ (run-hook '*debugger-hook* condition)
;; We definitely want *PACKAGE* to be of valid type.
;;
;;; halt-on-failures and prompt-on-failures modes, suitable for
;;; noninteractive and interactive use respectively
(defun disable-debugger ()
+ "When invoked, this function will turn off both the SBCL debugger
+and LDB (the low-level debugger). See also ENABLE-DEBUGGER."
;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
;; to set it to a suitable value again and be very careful,
(function sb!alien:void))))
(defun enable-debugger ()
+ "Restore the debugger if it has been turned off by DISABLE-DEBUGGER."
(when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
(setf *invoke-debugger-hook* *old-debugger-hook*
*old-debugger-hook* nil))
(t
(funcall cmd-fun))))))))))))
+(defvar *auto-eval-in-frame* t
+ #!+sb-doc
+ "When set (the default), evaluations in the debugger's command loop occur
+ relative to the current frame's environment without the need of debugger
+ forms that explicitly control this kind of evaluation.")
+
+(defun debug-eval (expr)
+ (cond ((not (and (fboundp 'compile) *auto-eval-in-frame*))
+ (eval expr))
+ ((frame-has-debug-vars-p *current-frame*)
+ (sb!di:eval-in-frame *current-frame* expr))
+ (t
+ (format *debug-io* "; No debug variables for current frame: ~
+ using EVAL instead of EVAL-IN-FRAME.~%")
+ (eval expr))))
+
(defun debug-eval-print (expr)
(/noshow "entering DEBUG-EVAL-PRINT" expr)
- (let ((values (multiple-value-list (interactive-eval expr))))
+ (let ((values (multiple-value-list
+ (interactive-eval expr :eval #'debug-eval))))
(/noshow "done with EVAL in DEBUG-EVAL-PRINT")
(dolist (value values)
(fresh-line *debug-io*)
(location (sb!di:frame-code-location *current-frame*))
(prefix (read-if-available nil))
(any-p nil)
- (any-valid-p nil))
+ (any-valid-p nil)
+ (more-context nil)
+ (more-count nil))
(dolist (v (sb!di:ambiguous-debug-vars
- d-fun
- (if prefix (string prefix) "")))
+ d-fun
+ (if prefix (string prefix) "")))
(setf any-p t)
(when (eq (sb!di:debug-var-validity v location) :valid)
(setf any-valid-p t)
+ (case (sb!di::debug-var-info v)
+ (:more-context
+ (setf more-context (sb!di:debug-var-value v *current-frame*)))
+ (:more-count
+ (setf more-count (sb!di:debug-var-value v *current-frame*))))
(format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
(sb!di:debug-var-symbol v)
(zerop (sb!di:debug-var-id v))
(sb!di:debug-var-id v)
(sb!di:debug-var-value v *current-frame*))))
-
+ (when (and more-context more-count)
+ (format *debug-io* "~S = ~S~%"
+ 'more
+ (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count))))
(cond
((not any-p)
(format *debug-io*
(values *cached-form-number-translations* *cached-toplevel-form*)
(let* ((offset (sb!di:code-location-toplevel-form-offset location))
(res
- (ecase (sb!di:debug-source-from d-source)
- (:file (get-file-toplevel-form location))
- (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
+ (cond ((sb!di:debug-source-namestring d-source)
+ (get-file-toplevel-form location))
+ ((sb!di:debug-source-form d-source)
+ (sb!di:debug-source-form d-source))
+ (t (bug "Don't know how to use a DEBUG-SOURCE without ~
+ a namestring or a form.")))))
(setq *cached-toplevel-form-offset* offset)
(values (setq *cached-form-number-translations*
(sb!di:form-number-translations res offset))
(aref (or (sb!di:debug-source-start-positions d-source)
(error "no start positions map"))
local-tlf-offset))
- (name (sb!di:debug-source-name d-source)))
+ (name (sb!di:debug-source-namestring d-source)))
(unless (eq d-source *cached-debug-source*)
(unless (and *cached-source-stream*
(equal (pathname *cached-source-stream*)
(!def-debug-command "SLURP" ()
(loop while (read-char-no-hang *standard-input*)))
+;;; RETURN-FROM-FRAME and RESTART-FRAME
+
+(defun unwind-to-frame-and-call (frame thunk)
+ #!+unwind-to-frame-and-call-vop
+ (flet ((sap-int/fixnum (sap)
+ ;; On unithreaded X86 *BINDING-STACK-POINTER* and
+ ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through
+ ;; some hoops to make these calculated values negative too.
+ (ash (truly-the (signed-byte #.sb!vm:n-word-bits)
+ (sap-int sap))
+ (- sb!vm::n-fixnum-tag-bits))))
+ ;; To properly unwind the stack, we need three pieces of information:
+ ;; * The unwind block that should be active after the unwind
+ ;; * The catch block that should be active after the unwind
+ ;; * The values that the binding stack pointer should have after the
+ ;; unwind.
+ (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame)))
+ (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame))))
+ ;; This VOP will run the neccessary cleanup forms, reset the fp, and
+ ;; then call the supplied function.
+ (sb!vm::%primitive sb!vm::unwind-to-frame-and-call
+ (sb!di::frame-pointer frame)
+ (find-enclosing-uwp frame)
+ (lambda ()
+ ;; Before calling the user-specified
+ ;; function, we need to restore the binding
+ ;; stack and the catch block. The unwind block
+ ;; is taken care of by the VOP.
+ (sb!vm::%primitive sb!vm::unbind-to-here
+ unbind-to)
+ (setf sb!vm::*current-catch-block* block)
+ (funcall thunk)))))
+ #!-unwind-to-frame-and-call-vop
+ (let ((tag (gensym)))
+ (sb!di:replace-frame-catch-tag frame
+ 'sb!c:debug-catch-tag
+ tag)
+ (throw tag thunk)))
+
+(defun find-binding-stack-pointer (frame)
+ #!-stack-grows-downward-not-upward
+ (declare (ignore frame))
+ #!-stack-grows-downward-not-upward
+ (error "Not implemented on this architecture")
+ #!+stack-grows-downward-not-upward
+ (let ((bsp (sb!vm::binding-stack-pointer-sap))
+ (unbind-to nil)
+ (fp (sb!di::frame-pointer frame))
+ (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm:*binding-stack-start*
+ sb!vm:n-fixnum-tag-bits)))))
+ ;; Walk the binding stack looking for an entry where the symbol is
+ ;; an unbound-symbol marker and the value is equal to the frame
+ ;; pointer. These entries are inserted into the stack by the
+ ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into
+ ;; the function during IR2). If an entry wasn't found, the
+ ;; function that the frame corresponds to wasn't compiled with a
+ ;; high enough debug setting, and can't be restarted / returned
+ ;; from.
+ (loop until (sap= bsp start)
+ do (progn
+ (setf bsp (sap+ bsp
+ (- (* sb!vm:binding-size sb!vm:n-word-bytes))))
+ (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot
+ sb!vm:n-word-bytes)))
+ (value (sap-ref-sap bsp (* sb!vm:binding-value-slot
+ sb!vm:n-word-bytes))))
+ (when (eql symbol sb!vm:unbound-marker-widetag)
+ (when (sap= value fp)
+ (setf unbind-to bsp))))))
+ unbind-to))
+
+(defun find-enclosing-catch-block (frame)
+ ;; Walk the catch block chain looking for the first entry with an address
+ ;; higher than the pointer for FRAME or a null pointer.
+ (let* ((frame-pointer (sb!di::frame-pointer frame))
+ (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm::*current-catch-block*
+ sb!vm:n-fixnum-tag-bits))))
+ (enclosing-block (loop for block = current-block
+ then (sap-ref-sap block
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm::n-word-bytes))
+ when (or (zerop (sap-int block))
+ (sap> block frame-pointer))
+ return block)))
+ enclosing-block))
+
+(defun find-enclosing-uwp (frame)
+ ;; Walk the UWP chain looking for the first entry with an address
+ ;; higher than the pointer for FRAME or a null pointer.
+ (let* ((frame-pointer (sb!di::frame-pointer frame))
+ (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm::*current-unwind-protect-block*
+ sb!vm:n-fixnum-tag-bits))))
+ (enclosing-uwp (loop for uwp-block = current-uwp
+ then (sap-ref-sap uwp-block
+ sb!vm:unwind-block-current-uwp-slot)
+ when (or (zerop (sap-int uwp-block))
+ (sap> uwp-block frame-pointer))
+ return uwp-block)))
+ enclosing-uwp))
+
(!def-debug-command "RETURN" (&optional
(return (read-prompting-maybe
"return: ")))
- (let ((tag (find-if (lambda (x)
- (and (typep (car x) 'symbol)
- (not (symbol-package (car x)))
- (string= (car x) "SB-DEBUG-CATCH-TAG")))
- (sb!di::frame-catches *current-frame*))))
- (if tag
- (throw (car tag)
- (funcall (sb!di:preprocess-for-eval
- return
- (sb!di:frame-code-location *current-frame*))
- *current-frame*))
- (format *debug-io*
- "~@<can't find a tag for this frame ~
+ (if (frame-has-debug-tag-p *current-frame*)
+ (let* ((code-location (sb!di:frame-code-location *current-frame*))
+ (values (multiple-value-list
+ (funcall (sb!di:preprocess-for-eval return code-location)
+ *current-frame*))))
+ (unwind-to-frame-and-call *current-frame* (lambda ()
+ (values-list values))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
~2I~_(hint: try increasing the DEBUG optimization quality ~
- and recompiling)~:@>"))))
+ and recompiling)~:@>")))
+
+(!def-debug-command "RESTART-FRAME" ()
+ (if (frame-has-debug-tag-p *current-frame*)
+ (let* ((call-list (frame-call-as-list *current-frame*))
+ (fun (fdefinition (car call-list))))
+ (unwind-to-frame-and-call *current-frame*
+ (lambda ()
+ (apply fun (cdr call-list)))))
+ (format *debug-io*
+ "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>")))
+
+(defun frame-has-debug-tag-p (frame)
+ #!+unwind-to-frame-and-call-vop
+ (not (null (find-binding-stack-pointer frame)))
+ #!-unwind-to-frame-and-call-vop
+ (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car))
+
+(defun frame-has-debug-vars-p (frame)
+ (sb!di:debug-var-info-available
+ (sb!di:code-location-debug-fun
+ (sb!di:frame-code-location frame))))
+
+;; Hack: ensure that *U-T-F-F* has a tls index.
+#!+unwind-to-frame-and-call-vop
+(let ((sb!vm::*unwind-to-frame-function* (lambda ()))))
+
\f
;;;; debug loop command utilities