(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
(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*)
(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*)
#!-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 ()))))
projects / sbcl.git / blobdiff