X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=5a5b0f375e438a4201aa9ee574be24e2219180b6;hb=e62bb3a4b9633dbd898fca05cc4af3dd0a16e0aa;hp=dd960198bc803cfcb398e19de76bf337b5a88c76;hpb=ad9afa9beaeac6c844fa999d0506b5ff71fb54ee;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index dd96019..5a5b0f3 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -170,33 +170,70 @@ Other commands: ;;;; 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)))) ;;;; frame printing @@ -210,6 +247,7 @@ is how many frames to show." optional rest keyword + more deleted) `(etypecase ,element (sb!di:debug-var @@ -218,7 +256,8 @@ is how many frames to show." (ecase (car ,element) (:optional ,@optional) (:rest ,@rest) - (:keyword ,@keyword))) + (:keyword ,@keyword) + (:more ,@more))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -234,38 +273,53 @@ is how many frames to show." ) ; 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"))))) + (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) @@ -303,6 +357,12 @@ is how many frames to show." ;; &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) @@ -317,9 +377,7 @@ is how many frames to show." (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 @@ -359,10 +417,17 @@ is how many frames to show." ;; 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) @@ -470,20 +535,24 @@ is how many frames to show." (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. ;; @@ -651,6 +720,8 @@ reset to ~S." ;;; 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, @@ -665,6 +736,7 @@ reset to ~S." (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)) @@ -794,9 +866,26 @@ reset to ~S." (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*) @@ -1178,19 +1267,29 @@ reset to ~S." (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* @@ -1259,9 +1358,12 @@ reset to ~S." (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)) @@ -1279,7 +1381,7 @@ reset to ~S." (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*) @@ -1379,6 +1481,8 @@ reset to ~S." (!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) @@ -1513,6 +1617,15 @@ reset to ~S." #!-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 ())))) + ;;;; debug loop command utilities