X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=1f633488e311e11cbf6222163811ec981a186879;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=150e3065b2ce6e644d462480f561c5eb69121f07;hpb=5ff7cae9ac087c5358e23310a4cf53baffc49e1e;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 150e306..1f63348 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -152,6 +152,11 @@ Other commands: useful when the debugger was invoked to handle an error in deeply nested input syntax, and now the reader is confused.)") +(defmacro with-debug-io-syntax (() &body body) + (let ((thunk (gensym "THUNK"))) + `(dx-flet ((,thunk () + ,@body)) + (funcall-with-debug-io-syntax #',thunk)))) ;;; If LOC is an unknown location, then try to find the block start ;;; location. Used by source printing to some information instead of @@ -328,15 +333,16 @@ METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames corresponding to method functions are printed. Possible values are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more information." - (fresh-line stream) - (when print-thread - (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*)) - (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*) - *suppress-print-errors* - 'serious-condition)) - (*print-circle* t) - (n start)) - (handler-bind ((print-not-readable #'print-unreadably)) + (with-debug-io-syntax () + (fresh-line stream) + (when print-thread + (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*)) + (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*) + *suppress-print-errors* + 'serious-condition)) + (*print-circle* t) + (n start)) + (handler-bind ((print-not-readable #'print-unreadably)) (map-backtrace (lambda (frame) (print-frame-call frame stream :number n @@ -346,8 +352,8 @@ information." :from (backtrace-start-frame from) :start start :count count))) - (fresh-line stream) - (values)) + (fresh-line stream) + (values))) (defun list-backtrace (&key (count *backtrace-frame-count*) @@ -512,12 +518,22 @@ thread, NIL otherwise." (sb!di:lambda-list-unavailable () (make-unprintable-object "unavailable lambda list")))) -(defun clean-xep (name args info) +(defun interrupted-frame-error (frame) + (when (and (sb!di::compiled-frame-p frame) + (sb!di::compiled-frame-escaped frame)) + (let ((error-number (sb!vm:internal-error-args + (sb!di::compiled-frame-escaped frame)))) + (when (array-in-bounds-p sb!c:*backend-internal-errors* error-number) + (car (svref sb!c:*backend-internal-errors* error-number)))))) + +(defun clean-xep (frame name args info) (values (second name) (if (consp args) (let* ((count (first args)) (real-args (rest args))) - (if (fixnump count) + (if (and (integerp count) + (eq (interrupted-frame-error frame) + 'invalid-arg-count-error)) ;; 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 @@ -568,21 +584,22 @@ thread, NIL otherwise." (values name args))) (values cname cargs (cons :fast-method info)))) -(defun clean-frame-call (name args method-frame-style info) - (if (consp name) - (case (first name) - ((sb!c::xep sb!c::tl-xep) - (clean-xep name args info)) - ((sb!c::&more-processor) - (clean-&more-processor name args info)) - ((sb!c::&optional-processor) - (clean-frame-call (second name) args method-frame-style - info)) - ((sb!pcl::fast-method) - (clean-fast-method name args method-frame-style info)) - (t - (values name args info))) - (values name args info))) +(defun clean-frame-call (frame name method-frame-style info) + (let ((args (frame-args-as-list frame))) + (if (consp name) + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-xep frame name args info)) + ((sb!c::&more-processor) + (clean-&more-processor name args info)) + ((sb!c::&optional-processor) + (clean-frame-call frame (second name) method-frame-style + info)) + ((sb!pcl::fast-method) + (clean-fast-method name args method-frame-style info)) + (t + (values name args info))) + (values name args info)))) (defun frame-call (frame &key (method-frame-style *method-frame-style*) replace-dynamic-extent-objects) @@ -603,8 +620,8 @@ the current thread are replaced with dummy objects which can safely escape." (let* ((debug-fun (sb!di:frame-debug-fun frame)) (kind (sb!di:debug-fun-kind debug-fun))) (multiple-value-bind (name args info) - (clean-frame-call (sb!di:debug-fun-name debug-fun) - (frame-args-as-list frame) + (clean-frame-call frame + (sb!di:debug-fun-name debug-fun) method-frame-style (when kind (list kind))) (let ((args (if (and (consp args) replace-dynamic-extent-objects) @@ -818,8 +835,8 @@ the current thread are replaced with dummy objects which can safely escape." (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." + "The value of ~S was not an undeleted PACKAGE. It has been ~ + reset to ~S." '*package* *package*)) ;; Before we start our own output, finish any pending output. @@ -912,64 +929,94 @@ reset to ~S." ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary ;;; ANSI behavior has been suppressed by the "--disable-debugger" ;;; command-line option -(defun debugger-disabled-hook (condition me) - (declare (ignore me)) +(defun debugger-disabled-hook (condition previous-hook) + (declare (ignore previous-hook)) ;; There is no one there to interact with, so report the ;; condition and terminate the program. - (flet ((failure-quit (&key abort) + (let ((*suppress-print-errors* t) + (condition-error-message + #.(format nil "A nested error within --disable-debugger error ~ + handling prevents displaying the original error. Attempting ~ + to print a backtrace.")) + (backtrace-error-message + #.(format nil "A nested error within --disable-debugger error ~ + handling prevents printing the backtrace. Sorry, exiting."))) + (labels + ((failure-quit (&key abort) (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") - (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 - ;; cleanly when the script dies (and our pipes are cut), instead - ;; of falling into ldb or something messy like that. Similarly, we - ;; can terminate cleanly even if BACKTRACE dies because of bugs in - ;; user PRINT-OBJECT methods. - (handler-case - (progn - (format *error-output* - "~&~@~2%" - (type-of condition) - #!+sb-thread sb!thread:*current-thread* - #!-sb-thread nil - condition) - ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that - ;; even if we hit an error within BACKTRACE (e.g. a bug in - ;; the debugger's own frame-walking code, or a bug in a user - ;; PRINT-OBJECT method) we'll at least have the CONDITION - ;; printed out before we die. - (finish-output *error-output*) - ;; (Where to truncate the BACKTRACE is of course arbitrary, but - ;; it seems as though we should at least truncate it somewhere.) - (print-backtrace :count 128 :stream *error-output* - :from :interrupted-frame) - (format - *error-output* - "~%unhandled condition in --disable-debugger mode, quitting~%") - (finish-output *error-output*) - (failure-quit)) - (condition () - ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can - ;; fail when our output streams are blown away, as e.g. when - ;; we're running under a Unix shell script and it dies somehow - ;; (e.g. because of a SIGINT). In that case, we might as well - ;; just give it up for a bad job, and stop trying to notify - ;; the user of anything. - ;; - ;; Actually, the only way I've run across to exercise the - ;; problem is to have more than one layer of shell script. - ;; I have a shell script which does - ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp - ;; and the problem occurs when I interrupt this with Ctrl-C - ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). - ;; I haven't figured out whether it's bash, time, tee, Linux, or - ;; what that is responsible, but that it's possible at all - ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 - (ignore-errors - (%primitive print - "Argh! error within --disable-debugger error handling")) - (failure-quit :abort t))))) + (exit :code 1 :abort abort)) + (display-condition () + (handler-case + (handler-case + (print-condition) + (condition () + ;; printing failed, try to describe it + (describe-condition))) + (condition () + ;; ok, give up trying to display the error and inform the user about it + (finish-output *error-output*) + (%primitive print condition-error-message)))) + (print-condition () + (format *error-output* + "~&~@~2%" + (type-of condition) + #!+sb-thread sb!thread:*current-thread* + #!-sb-thread nil + condition) + (finish-output *error-output*)) + (describe-condition () + (format *error-output* + "~&Unhandled ~S~@[ in thread ~S~]:~%" + (type-of condition) + #!+sb-thread sb!thread:*current-thread* + #!-sb-thread nil) + (describe condition *error-output*) + (finish-output *error-output*)) + (display-backtrace () + (handler-case + (print-backtrace :stream *error-output* + :from :interrupted-frame + :print-thread t) + (condition () + (values))) + (finish-output *error-output*))) + ;; 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 + ;; cleanly when the script dies (and our pipes are cut), instead + ;; of falling into ldb or something messy like that. Similarly, we + ;; can terminate cleanly even if BACKTRACE dies because of bugs in + ;; user PRINT-OBJECT methods. Separate the error handling of the + ;; two phases to maximize the chance of emitting some useful + ;; information. + (handler-case + (progn + (display-condition) + (display-backtrace) + (format *error-output* + "~%unhandled condition in --disable-debugger mode, quitting~%") + (finish-output *error-output*) + (failure-quit)) + (condition () + ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can + ;; fail when our output streams are blown away, as e.g. when + ;; we're running under a Unix shell script and it dies somehow + ;; (e.g. because of a SIGINT). In that case, we might as well + ;; just give it up for a bad job, and stop trying to notify + ;; the user of anything. + ;; + ;; Actually, the only way I've run across to exercise the + ;; problem is to have more than one layer of shell script. + ;; I have a shell script which does + ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp + ;; and the problem occurs when I interrupt this with Ctrl-C + ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). + ;; I haven't figured out whether it's bash, time, tee, Linux, or + ;; what that is responsible, but that it's possible at all + ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 + (ignore-errors + (%primitive print backtrace-error-message)) + (failure-quit :abort t)))))) (defvar *old-debugger-hook* nil) @@ -1063,12 +1110,12 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") -(defun debug-read (stream) +(defun debug-read (stream eof-restart) (declare (type stream stream)) (let* ((eof-marker (cons nil nil)) (form (read stream nil eof-marker))) (if (eq form eof-marker) - (abort) + (invoke-restart eof-restart) form))) (defun debug-loop-fun () @@ -1099,17 +1146,20 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." '*flush-debug-errors*) (/show0 "throwing DEBUG-LOOP-CATCHER") (throw 'debug-loop-catcher nil))))) - ;; We have to bind LEVEL for the restart function created by - ;; WITH-SIMPLE-RESTART. + ;; We have to bind LEVEL for the restart function created + ;; by WITH-SIMPLE-RESTART, and we need the explicit ABORT + ;; restart that exists now so that EOF from read can drop + ;; one debugger level. (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) + (restart-commands (make-restart-commands)) + (abort-restart-for-eof (find-restart 'abort))) (flush-standard-output-streams) (debug-prompt *debug-io*) (force-output *debug-io*) (with-simple-restart (abort "~@" level) - (let* ((exp (debug-read *debug-io*)) + (let* ((exp (debug-read *debug-io* abort-restart-for-eof)) (cmd-fun (debug-command-p exp restart-commands))) (cond ((not cmd-fun) (debug-eval-print exp)) @@ -1569,12 +1619,6 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." ;;;; source location printing -;;; Stuff to clean up before saving a core -(defun debug-deinit () - ;; 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))) @@ -1796,11 +1840,6 @@ and LDB (the low-level debugger). See also ENABLE-DEBUGGER." (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