X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=69715ba534a03917b67aafdf2b1911f6d03c24c3;hb=a6a12ed609d5467ec43b411283e5b3568fee81df;hp=05cef22c98a7355fc897cb0c951302160a3e630d;hpb=74cfbf6d0572b7df1b3492563408a7cb3ae103cf;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 05cef22..69715ba 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -62,12 +62,13 @@ provide bindings for printer control variables.") ;;; nestedness inside debugger command loops (defvar *debug-command-level* 0) -;;; If this is bound before the debugger is invoked, it is used as the -;;; stack top by the debugger. +;;; If this is bound before the debugger is invoked, it is used as the stack +;;; top by the debugger. It can either be the first interesting frame, or the +;;; name of the last uninteresting frame. (defvar *stack-top-hint* nil) -(defvar *stack-top* nil) (defvar *real-stack-top* nil) +(defvar *stack-top* nil) (defvar *current-frame* nil) @@ -191,23 +192,54 @@ Other commands: In the debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line stream) - (map-backtrace (lambda (frame) - (print-frame-call frame stream :number t)) - :count count) + (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*) + *suppress-print-errors* + 'serious-condition)) + (*print-circle* t)) + (handler-bind ((print-not-readable #'print-unreadably)) + (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." + #!+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)))) ;;;; frame printing @@ -221,6 +253,7 @@ is how many frames to show." optional rest keyword + more deleted) `(etypecase ,element (sb!di:debug-var @@ -229,7 +262,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))) @@ -267,15 +301,27 @@ is how many frames to show." :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 () @@ -286,11 +332,18 @@ is how many frames to show." (defun clean-xep (name args) (values (second name) (if (consp args) - (let ((count (first args)) - (real-args (rest args))) + (let* ((count (first args)) + (real-args (rest args))) (if (fixnump count) - (subseq real-args 0 - (min count (length real-args))) + ;; So, this is a cheap trick -- but makes backtraces for + ;; too-many-arguments-errors much, much easier to to + ;; understand. FIXME: For :EXTERNAL frames at least we + ;; should be able to get the actual arguments, really. + (loop repeat count + for arg = (if real-args + (pop real-args) + (make-unprintable-object "unknown")) + collect arg) real-args)) args))) @@ -309,23 +362,28 @@ is how many frames to show." (make-unprintable-object "more unavailable arguments"))))) args))) +(defun clean-debug-fun-name (name &optional args) + ;; FIXME: do we need to deal with + ;; HAIRY-FUNCTION-ENTRY here? I can't make it or + ;; &AUX-BINDINGS appear in backtraces, so they are + ;; left alone for now. --NS 2005-02-28 + (if (consp name) + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-xep name args)) + ((sb!c::&more-processor) + (clean-&more-processor name args)) + ((sb!c::hairy-arg-processor + sb!c::varargs-entry sb!c::&optional-processor) + (clean-debug-fun-name (second name) args)) + (t + (values name args))) + (values name args))) + (defun frame-call (frame) (labels ((clean-name-and-args (name args) - (if (and (consp name) (not *show-entry-point-details*)) - ;; FIXME: do we need to deal with - ;; HAIRY-FUNCTION-ENTRY here? I can't make it or - ;; &AUX-BINDINGS appear in backtraces, so they are - ;; left alone for now. --NS 2005-02-28 - (case (first name) - ((sb!c::xep sb!c::tl-xep) - (clean-xep name args)) - ((sb!c::&more-processor) - (clean-&more-processor name args)) - ((sb!c::hairy-arg-processor - sb!c::varargs-entry sb!c::&optional-processor) - (clean-name-and-args (second name) args)) - (t - (values name args))) + (if (not *show-entry-point-details*) + (clean-debug-fun-name name args) (values name args)))) (let ((debug-fun (sb!di:frame-debug-fun frame))) (multiple-value-bind (name args) @@ -367,14 +425,20 @@ is how many frames to show." ;; For the function arguments, we can just print normally. (let ((*print-length* nil) (*print-level* nil)) - (prin1 (ensure-printable-object name) stream)) - ;; 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)))) + (prin1 name stream)) + ;; 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. Special case *PRINT-PRETTY* for eval frames: + ;; if *PRINT-LINES* is 1, turn off pretty-printing. + (let ((*print-pretty* + (if (and (eql 1 *print-lines*) + (member name '(eval simple-eval-in-lexenv))) + nil + *print-pretty*)))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args))) (when kind (format stream "[~S]" kind)))) (when (>= verbosity 2) @@ -492,35 +556,57 @@ is how many frames to show." (progv (list variable) (list nil) (funcall old-hook condition old-hook))))) +;;; We can bind *stack-top-hint* to a symbol, in which case this function will +;;; resolve that hint lazily before we enter the debugger. +(defun resolve-stack-top-hint () + (let ((hint *stack-top-hint*) + (*stack-top-hint* nil)) + (cond + ;; No hint, just keep the debugger guts out. + ((not hint) + (find-caller-name-and-frame)) + ;; Interrupted. Look for the interrupted frame -- if we don't find one + ;; this falls back to the next case. + ((and (eq hint 'invoke-interruption) + (nth-value 1 (find-interrupted-name-and-frame)))) + ;; Name of the first uninteresting frame. + ((symbolp hint) + (find-caller-of-named-frame hint)) + ;; We already have a resolved hint. + (t + hint)))) + (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 - (run-hook '*invoke-debugger-hook* condition) - (run-hook '*debugger-hook* condition) - - ;; We definitely want *PACKAGE* to be of valid type. - ;; - ;; Elsewhere in the system, we use the SANE-PACKAGE function for - ;; this, but here causing an exception just as we're trying to handle - ;; an exception would be confusing, so instead we use a special hack. - (unless (and (packagep *package*) - (package-name *package*)) - (setf *package* (find-package :cl-user)) - (format *error-output* - "The value of ~S was not an undeleted PACKAGE. It has been + (let ((*stack-top-hint* (resolve-stack-top-hint))) + + ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not + ;; called when the debugger is disabled + (run-hook '*invoke-debugger-hook* condition) + (run-hook '*debugger-hook* condition) + + ;; We definitely want *PACKAGE* to be of valid type. + ;; + ;; Elsewhere in the system, we use the SANE-PACKAGE function for + ;; this, but here causing an exception just as we're trying to handle + ;; an exception would be confusing, so instead we use a special hack. + (unless (and (packagep *package*) + (package-name *package*)) + (setf *package* (find-package :cl-user)) + (format *error-output* + "The value of ~S was not an undeleted PACKAGE. It has been reset to ~S." - '*package* *package*)) + '*package* *package*)) - ;; Before we start our own output, finish any pending output. - ;; Otherwise, if the user tried to track the progress of his program - ;; using PRINT statements, he'd tend to lose the last line of output - ;; or so, which'd be confusing. - (flush-standard-output-streams) + ;; Before we start our own output, finish any pending output. + ;; Otherwise, if the user tried to track the progress of his program + ;; using PRINT statements, he'd tend to lose the last line of output + ;; or so, which'd be confusing. + (flush-standard-output-streams) - (funcall-with-debug-io-syntax #'%invoke-debugger condition)) + (funcall-with-debug-io-syntax #'%invoke-debugger condition))) (defun %print-debugger-invocation-reason (condition stream) (format stream "~2&") @@ -530,7 +616,7 @@ reset to ~S." ;; definitely preferred, because the FORMAT alternative was acting odd. (pprint-logical-block (stream nil) (format stream - "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A" + "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A" (type-of condition) #!+sb-thread sb!thread:*current-thread* #!-sb-thread nil @@ -608,9 +694,9 @@ reset to ~S." (declare (ignore me)) ;; There is no one there to interact with, so report the ;; condition and terminate the program. - (flet ((failure-quit (&key recklessly-p) + (flet ((failure-quit (&key abort) (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") - (quit :unix-status 1 :recklessly-p recklessly-p))) + (exit :code 1 :abort abort))) ;; This HANDLER-CASE is here mostly to stop output immediately ;; (and fall through to QUIT) when there's an I/O error. Thus, ;; when we're run under a shell script or something, we can die @@ -660,7 +746,7 @@ reset to ~S." (ignore-errors (%primitive print "Argh! error within --disable-debugger error handling")) - (failure-quit :recklessly-p t))))) + (failure-quit :abort t))))) (defvar *old-debugger-hook* nil) @@ -820,9 +906,14 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." 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) @@ -1209,19 +1300,29 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (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* @@ -1245,124 +1346,25 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." ;;;; source location printing -;;; We cache a stream to the last valid file debug source so that we -;;; won't have to repeatedly open the file. -;;; -;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast -;;; in the 1990s, so the benefit is negligible, less important than the -;;; potential of extra confusion if someone changes the source during -;;; a debug session and the change doesn't show up. And removing this -;;; would simplify the system, which I like. -- WHN 19990903 -(defvar *cached-debug-source* nil) -(declaim (type (or sb!di:debug-source null) *cached-debug-source*)) -(defvar *cached-source-stream* nil) -(declaim (type (or stream null) *cached-source-stream*)) - -;;; To suppress the read-time evaluation #. macro during source read, -;;; *READTABLE* is modified. *READTABLE* is cached to avoid -;;; copying it each time, and invalidated when the -;;; *CACHED-DEBUG-SOURCE* has changed. -(defvar *cached-readtable* nil) -(declaim (type (or readtable null) *cached-readtable*)) - ;;; Stuff to clean up before saving a core (defun debug-deinit () - (setf *cached-debug-source* nil - *cached-source-stream* nil - *cached-readtable* nil)) - -;;; We also cache the last toplevel form that we printed a source for -;;; so that we don't have to do repeated reads and calls to -;;; FORM-NUMBER-TRANSLATIONS. -(defvar *cached-toplevel-form-offset* nil) -(declaim (type (or index null) *cached-toplevel-form-offset*)) -(defvar *cached-toplevel-form*) -(defvar *cached-form-number-translations*) - -;;; Given a code location, return the associated form-number -;;; translations and the actual top level form. We check our cache --- -;;; if there is a miss, we dispatch on the kind of the debug source. -(defun get-toplevel-form (location) - (let ((d-source (sb!di:code-location-debug-source location))) - (if (and (eq d-source *cached-debug-source*) - (eql (sb!di:code-location-toplevel-form-offset location) - *cached-toplevel-form-offset*)) - (values *cached-form-number-translations* *cached-toplevel-form*) - (let* ((offset (sb!di:code-location-toplevel-form-offset location)) - (res - (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)) - (setq *cached-toplevel-form* res)))))) - -;;; Locate the source file (if it still exists) and grab the top level -;;; form. If the file is modified, we use the top level form offset -;;; instead of the recorded character offset. -(defun get-file-toplevel-form (location) - (let* ((d-source (sb!di:code-location-debug-source location)) - (tlf-offset (sb!di:code-location-toplevel-form-offset location)) - (local-tlf-offset (- tlf-offset - (sb!di:debug-source-root-number d-source))) - (char-offset - (aref (or (sb!di:debug-source-start-positions d-source) - (error "no start positions map")) - local-tlf-offset)) - (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*) - (pathname name))) - (setq *cached-readtable* nil) - (when *cached-source-stream* (close *cached-source-stream*)) - (setq *cached-source-stream* (open name :if-does-not-exist nil)) - (unless *cached-source-stream* - (error "The source file no longer exists:~% ~A" (namestring name))) - (format *debug-io* "~%; file: ~A~%" (namestring name))) - - (setq *cached-debug-source* - (if (= (sb!di:debug-source-created d-source) - (file-write-date name)) - d-source nil))) - - (cond - ((eq *cached-debug-source* d-source) - (file-position *cached-source-stream* char-offset)) - (t - (format *debug-io* - "~%; File has been modified since compilation:~%; ~A~@ - ; Using form offset instead of character position.~%" - (namestring name)) - (file-position *cached-source-stream* 0) - (let ((*read-suppress* t)) - (dotimes (i local-tlf-offset) - (read *cached-source-stream*))))) - (unless *cached-readtable* - (setq *cached-readtable* (copy-readtable)) - (set-dispatch-macro-character - #\# #\. - (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token))) - *cached-readtable*)) - (let ((*readtable* *cached-readtable*)) - (read *cached-source-stream*)))) - -(defun code-location-source-form (location context) - (let* ((location (maybe-block-start-location location)) - (form-num (sb!di:code-location-form-number location))) - (multiple-value-bind (translations form) (get-toplevel-form location) - (unless (< form-num (length translations)) - (error "The source path no longer exists.")) - (sb!di:source-path-context form - (svref translations form-num) - context)))) + ;; Nothing to do right now. Once there was, maybe once there + ;; will be again. + ) + +(defun code-location-source-form (location context &optional (errorp t)) + (let* ((start-location (maybe-block-start-location location)) + (form-num (sb!di:code-location-form-number start-location))) + (multiple-value-bind (translations form) + (sb!di:get-toplevel-form start-location) + (cond ((< form-num (length translations)) + (sb!di:source-path-context form + (svref translations form-num) + context)) + (t + (funcall (if errorp #'error #'warn) + "~@")))))) ;;; start single-stepping @@ -1533,15 +1535,33 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (!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))))) + (multiple-value-bind (fname args) (frame-call *current-frame*) + (multiple-value-bind (fun arglist ok) + (if (and (legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args t) + (values (sb!di:debug-fun-fun (sb!di:frame-debug-fun *current-frame*)) + (frame-args-as-list *current-frame*) + nil)) + (when (and fun + (or ok + (y-or-n-p "~@"))) + (unwind-to-frame-and-call *current-frame* + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist)))) + (format *debug-io* + "Can't restart ~S: no function for frame." + *current-frame*))) (format *debug-io* - "~@"))) + "~@" + *current-frame*))) (defun frame-has-debug-tag-p (frame) #!+unwind-to-frame-and-call-vop @@ -1549,6 +1569,11 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." #!-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 ()))))