(values))
(defun backtrace-as-list (&optional (count most-positive-fixnum))
- #!+sb-doc "Return a list representing the current BACKTRACE."
+ #!+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)
- (push (frame-call-as-list frame) reversed-result))
+ (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)))
:deleted ((push (frame-call-arg element location frame) reversed-result))
:rest ((lambda-var-dispatch (second element) location
nil
- (progn
- (setf reversed-result
- (append (reverse (sb!di:debug-var-value
- (second element) frame))
- reversed-result))
+ (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)))))
+ 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 ()
;; &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)
;; 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)
;;; 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))
forms that explicitly control this kind of evaluation.")
(defun debug-eval (expr)
- (if (and (fboundp 'compile) *auto-eval-in-frame*)
- (sb!di:eval-in-frame *current-frame* expr)
- (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)
(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*
#!-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 ()))))