X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=bb786294bcd2d11a5ef0a19deefd4b26ac3dd938;hb=b66385e2031fc2cac17dd129df0af400beb48a22;hp=b20dc7ee737c0e5a3bff25ed7c394f0a55d6b018;hpb=64f013aaf9d09edb2d82cb7eed6cb098bbbc169a;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index b20dc7e..bb78629 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -24,7 +24,7 @@ ;;; * As condition :REPORT methods are converted to use the pretty ;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under ;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an -;;; ARG-COUNT-ERROR printed as +;;; ARG-COUNT-ERROR printed as ;;; error while parsing arguments to DESTRUCTURING-BIND: ;;; invalid number of elements in ;;; # @@ -81,18 +81,18 @@ provide bindings for printer control variables.") (defun debug-prompt (stream) (sb!thread::get-foreground) (format stream - "~%~W~:[~;[~W~]] " - (sb!di:frame-number *current-frame*) - (> *debug-command-level* 1) - *debug-command-level*)) - + "~%~W~:[~;[~W~]] " + (sb!di:frame-number *current-frame*) + (> *debug-command-level* 1) + *debug-command-level*)) + (defparameter *debug-help-string* "The debug prompt is square brackets, with number(s) indicating the current control stack level and, if you've entered the debugger recursively, how deeply recursed you are. Any command -- including the name of a restart -- may be uniquely abbreviated. The debugger rebinds various special variables for controlling i/o, sometimes - to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to + to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*. Debug commands do not affect *, //, and similar variables, but evaluation in the debug loop does affect these variables. @@ -120,9 +120,14 @@ Inspecting frames: SOURCE [n] displays frame's source form with n levels of enclosing forms. Stepping: - STEP Selects the CONTINUE restart if one exists and starts + START Selects the CONTINUE restart if one exists and starts single-stepping. Single stepping affects only code compiled with under high DEBUG optimization quality. See User Manual for details. + STEP Steps into the current form. + NEXT Steps over the current form. + OUT Stops stepping temporarily, but resumes it when the topmost frame that + was stepped into returns. + STOP Stops single-stepping. Function and macro commands: (SB-DEBUG:ARG n) @@ -148,14 +153,14 @@ Other commands: (defun maybe-block-start-location (loc) (if (sb!di:code-location-unknown-p loc) (let* ((block (sb!di:code-location-debug-block loc)) - (start (sb!di:do-debug-block-locations (loc block) - (return loc)))) - (cond ((and (not (sb!di:debug-block-elsewhere-p block)) - start) - (format *debug-io* "~%unknown location: using block start~%") - start) - (t - loc))) + (start (sb!di:do-debug-block-locations (loc block) + (return loc)))) + (cond ((and (not (sb!di:debug-block-elsewhere-p block)) + start) + (format *debug-io* "~%unknown location: using block start~%") + start) + (t + loc))) loc)) ;;;; BACKTRACE @@ -167,7 +172,7 @@ 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)) + (sb!di:frame-down frame)) (count count (1- count))) ((or (null frame) (zerop count))) (print-frame-call frame stream :number t)) @@ -178,7 +183,7 @@ is how many frames to show." #!+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)) + (sb!di:frame-down frame)) (count count (1- count))) ((or (null frame) (zerop count)) (nreverse reversed-result)) @@ -195,20 +200,20 @@ is how many frames to show." ;;; This is a convenient way to express what to do for each type of ;;; lambda-list element. (sb!xc:defmacro lambda-list-element-dispatch (element - &key - required - optional - rest - keyword - deleted) + &key + required + optional + rest + keyword + deleted) `(etypecase ,element (sb!di:debug-var ,@required) (cons (ecase (car ,element) - (:optional ,@optional) - (:rest ,@rest) - (:keyword ,@keyword))) + (:optional ,@optional) + (:rest ,@rest) + (:keyword ,@keyword))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -217,83 +222,87 @@ is how many frames to show." (let ((var (gensym))) `(let ((,var ,variable)) (cond ((eq ,var :deleted) ,deleted) - ((eq (sb!di:debug-var-validity ,var ,location) :valid) - ,valid) - (t ,other))))) + ((eq (sb!di:debug-var-validity ,var ,location) :valid) + ,valid) + (t ,other))))) ) ; EVAL-WHEN -;;; This is used in constructing arg lists for debugger printing when -;;; the arg list is unavailable, some arg is unavailable or unused, etc. -(defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (write-string (unprintable-object-string x) - s)))) - (:copier nil)) - string) - ;;; Extract the function argument values for a debug frame. (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)) + (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)) + (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"))))) (legal-fun-name-p '(lambda ())) (defvar *show-entry-point-details* nil) +(defun clean-xep (name args) + (values (second name) + (if (consp args) + (let ((count (first args)) + (real-args (rest args))) + (if (fixnump count) + (subseq real-args 0 + (min count (length real-args))) + real-args)) + args))) + +(defun clean-&more-processor (name args) + (values (second name) + (if (consp args) + (let* ((more (last args 2)) + (context (first more)) + (count (second more))) + (append + (butlast args 2) + (if (fixnump count) + (multiple-value-list + (sb!c:%more-arg-values context 0 count)) + (list + (make-unprintable-object "more unavailable arguments"))))) + 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-name-and-args - (second name) - (let ((count (first args)) - (real-args (rest args))) - (subseq real-args 0 (min count (length real-args)))))) + (clean-xep name args)) ((sb!c::&more-processor) - (clean-name-and-args - (second name) - (let* ((more (last args 2)) - (context (first more)) - (count (second more))) - (append (butlast args 2) - (multiple-value-list - (sb!c:%more-arg-values context 0 count)))))) - ;; 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 - ((sb!c::hairy-arg-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 @@ -310,8 +319,8 @@ is how many frames to show." (defun ensure-printable-object (object) (handler-case (with-open-stream (out (make-broadcast-stream)) - (prin1 object out) - object) + (prin1 object out) + object) (error (cond) (declare (ignore cond)) (make-unprintable-object "error printing object")))) @@ -354,16 +363,16 @@ is how many frames to show." (when (>= verbosity 2) (let ((loc (sb!di:frame-code-location frame))) (handler-case - (progn + (progn ;; FIXME: Is this call really necessary here? If it is, ;; then the reason for it should be unobscured. - (sb!di:code-location-debug-block loc) - (format stream "~%source: ") - (prin1 (code-location-source-form loc 0) stream)) - (sb!di:debug-condition (ignore) + (sb!di:code-location-debug-block loc) + (format stream "~%source: ") + (prin1 (code-location-source-form loc 0) stream)) + (sb!di:debug-condition (ignore) ignore) - (error (c) - (format stream "error finding source: ~A" c)))))) + (error (c) + (format stream "~&error finding source: ~A" c)))))) ;;;; INVOKE-DEBUGGER @@ -380,8 +389,8 @@ is how many frames to show." "This is either NIL or a designator for a function of two arguments, to be run when the debugger is about to be entered. The function is run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive - errors, and receives as arguments the condition that triggered - debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* + errors, and receives as arguments the condition that triggered + debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*. In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when @@ -400,17 +409,17 @@ is how many frames to show." (declare (type function fun)) ;; Try to force the other special variables into a useful state. (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where - ;; any default we might use is less useful than just reusing - ;; the global values. - (original-package *package*) - (original-print-pretty *print-pretty*)) + ;; any default we might use is less useful than just reusing + ;; the global values. + (original-package *package*) + (original-print-pretty *print-pretty*)) (with-standard-io-syntax (with-sane-io-syntax (let (;; We want the printer and reader to be in a useful ;; state, regardless of where the debugger was invoked ;; in the program. WITH-STANDARD-IO-SYNTAX and ;; WITH-SANE-IO-SYNTAX do much of what we want, but - ;; * It doesn't affect our internal special variables + ;; * It doesn't affect our internal special variables ;; like *CURRENT-LEVEL-IN-PRINT*. ;; * It isn't customizable. ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not @@ -456,28 +465,20 @@ is how many frames to show." (nreverse (mapcar #'cdr *debug-print-variable-alist*)) (apply fun rest))))))) -;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by -;;; command-line --disable-debugger option (defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." - (let ((old-hook *debugger-hook*)) - (when old-hook - (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + ;; 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)))) - - ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the - ;; signal state in the case that we wind up in the debugger as a - ;; result of something done by a signal handler. It's not - ;; altogether obvious that this is necessary, and indeed SBCL has - ;; not been doing it since 0.7.8.5. But nobody seems altogether - ;; convinced yet - ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28 + (funcall old-hook condition old-hook)))) + (let ((old-hook *debugger-hook*)) + (when old-hook + (let ((*debugger-hook* nil)) + (funcall old-hook condition old-hook)))) ;; We definitely want *PACKAGE* to be of valid type. ;; @@ -485,12 +486,12 @@ is how many frames to show." ;; 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*)) + (package-name *package*)) (setf *package* (find-package :cl-user)) (format *error-output* - "The value of ~S was not an undeleted PACKAGE. It has been + "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 @@ -500,43 +501,53 @@ reset to ~S." (funcall-with-debug-io-syntax #'%invoke-debugger condition)) +(defun %print-debugger-invocation-reason (condition stream) + (format stream "~2&") + ;; Note: Ordinarily it's only a matter of taste whether to use + ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but + ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is + ;; 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" + (type-of condition) + #!+sb-thread sb!thread:*current-thread* + #!-sb-thread nil + condition)) + (terpri stream)) + (defun %invoke-debugger (condition) - (let ((*debug-condition* condition) - (*debug-restarts* (compute-restarts condition)) - (*nested-debug-condition* nil)) + (*debug-restarts* (compute-restarts condition)) + (*nested-debug-condition* nil)) (handler-case - ;; (The initial output here goes to *ERROR-OUTPUT*, because the - ;; initial output is not interactive, just an error message, and - ;; when people redirect *ERROR-OUTPUT*, they could reasonably - ;; expect to see error messages logged there, regardless of what - ;; the debugger does afterwards.) - (format *error-output* - "~2&~@~%" - (type-of *debug-condition*) - (sb!thread:current-thread-id) - *debug-condition*) + ;; (The initial output here goes to *ERROR-OUTPUT*, because the + ;; initial output is not interactive, just an error message, and + ;; when people redirect *ERROR-OUTPUT*, they could reasonably + ;; expect to see error messages logged there, regardless of what + ;; the debugger does afterwards.) + (unless (typep condition 'step-condition) + (%print-debugger-invocation-reason condition *error-output*)) (error (condition) - (setf *nested-debug-condition* condition) - (let ((ndc-type (type-of *nested-debug-condition*))) - (format *error-output* - "~&~@<(A ~S was caught when trying to print ~S when ~ + (setf *nested-debug-condition* condition) + (let ((ndc-type (type-of *nested-debug-condition*))) + (format *error-output* + "~&~@<(A ~S was caught when trying to print ~S when ~ entering the debugger. Printing was aborted and the ~ ~S was stored in ~S.)~@:>~%" - ndc-type - '*debug-condition* - ndc-type - '*nested-debug-condition*)) - (when (typep condition 'cell-error) - ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: - (format *error-output* - "~&(CELL-ERROR-NAME ~S) = ~S~%" - '*debug-condition* - (cell-error-name *debug-condition*))))) + ndc-type + '*debug-condition* + ndc-type + '*nested-debug-condition*)) + (when (typep *nested-debug-condition* 'cell-error) + ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: + (format *error-output* + "~&(CELL-ERROR-NAME ~S) = ~S~%" + '*nested-debug-condition* + (cell-error-name *nested-debug-condition*))))) (let ((background-p (sb!thread::debugger-wait-until-foreground-thread - *debug-io*))) + *debug-io*))) ;; After the initial error/condition/whatever announcement to ;; *ERROR-OUTPUT*, we become interactive, and should talk on @@ -547,27 +558,27 @@ reset to ~S." ;; been converted to behave this way. -- WHN 2000-11-16) (unwind-protect - (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO* - ;; here as well, but that is probably bogus since it + (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO* + ;; here as well, but that is probably bogus since it ;; removes the users ability to do output to a redirected ;; *S-O*. Now we just rebind it so that users can temporarily ;; frob it. FIXME: This and other "what gets bound when" ;; behaviour should be documented in the manual. (*standard-output* *standard-output*) ;; This seems reasonable: e.g. if the user has redirected - ;; *ERROR-OUTPUT* to some log file, it's probably wrong - ;; to send errors which occur in interactive debugging to - ;; that file, and right to send them to *DEBUG-IO*. - (*error-output* *debug-io*)) - (unless (typep condition 'step-condition) - (when *debug-beginner-help-p* - (format *debug-io* - "~%~@~2%")) - (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)) - (when background-p - (sb!thread::release-foreground)))))) + (show-restarts *debug-restarts* *debug-io*)) + (internal-debug)) + (when background-p + (sb!thread::release-foreground)))))) ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary ;;; ANSI behavior has been suppressed by the "--disable-debugger" @@ -578,7 +589,7 @@ reset to ~S." ;; condition and terminate the program. (flet ((failure-quit (&key recklessly-p) (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") - (quit :unix-status 1 :recklessly-p recklessly-p))) + (quit :unix-status 1 :recklessly-p recklessly-p))) ;; 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 @@ -587,97 +598,115 @@ reset to ~S." ;; 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:current-thread-id) - 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.) - (sb!debug:backtrace 128 *error-output*) - (format - *error-output* - "~%unhandled condition in --disable-debugger mode, quitting~%") - (finish-output *error-output*) - (failure-quit)) + (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.) + (sb!debug:backtrace 128 *error-output*) + (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. + ;; 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). + ;; 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 + ;; 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 :recklessly-p t))))) + "Argh! error within --disable-debugger error handling")) + (failure-quit :recklessly-p t))))) + +(defvar *old-debugger-hook* nil) ;;; halt-on-failures and prompt-on-failures modes, suitable for ;;; noninteractive and interactive use respectively (defun disable-debugger () - (when (eql *invoke-debugger-hook* nil) - (setf *debug-io* *error-output* - *invoke-debugger-hook* 'debugger-disabled-hook))) + ;; *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, + ;; especially if the user has also set it. -- MG 2005-07-15 + (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *old-debugger-hook* *invoke-debugger-hook* + *invoke-debugger-hook* 'debugger-disabled-hook)) + ;; This is not inside the UNLESS to ensure that LDB is disabled + ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was. + ;; This might matter for example when restoring a core. + (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler" + (function sb!alien:void)))) (defun enable-debugger () (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) - (setf *invoke-debugger-hook* nil))) - -(setf *debug-io* *query-io*) + (setf *invoke-debugger-hook* *old-debugger-hook* + *old-debugger-hook* nil)) + (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler" + (function sb!alien:void)))) (defun show-restarts (restarts s) (cond ((null restarts) - (format s - "~&(no restarts: If you didn't do this on purpose, ~ + (format s + "~&(no restarts: If you didn't do this on purpose, ~ please report it as a bug.)~%")) - (t - (format s "~&restarts (invokable by number or by ~ + (t + (format s "~&restarts (invokable by number or by ~ possibly-abbreviated name):~%") - (let ((count 0) - (names-used '(nil)) - (max-name-len 0)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - (when name - (let ((len (length (princ-to-string name)))) - (when (> len max-name-len) - (setf max-name-len len)))))) - (unless (zerop max-name-len) - (incf max-name-len 3)) - (dolist (restart restarts) - (let ((name (restart-name restart))) - ;; FIXME: maybe it would be better to display later names - ;; in parens instead of brakets, not just omit them fully. - ;; Call BREAK, call BREAK in the debugger, and tell me - ;; it's not confusing looking. --NS 20050310 - (cond ((member name names-used) - (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) - (t - (format s "~& ~2D: [~VA] ~A~%" - count (- max-name-len 3) name restart) - (push name names-used)))) - (incf count)))))) + (let ((count 0) + (names-used '(nil)) + (max-name-len 0)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (when name + (let ((len (length (princ-to-string name)))) + (when (> len max-name-len) + (setf max-name-len len)))))) + (unless (zerop max-name-len) + (incf max-name-len 3)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + ;; FIXME: maybe it would be better to display later names + ;; in parens instead of brakets, not just omit them fully. + ;; Call BREAK, call BREAK in the debugger, and tell me + ;; it's not confusing looking. --NS 20050310 + (cond ((member name names-used) + (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) + (t + (format s "~& ~2D: [~VA] ~A~%" + count (- max-name-len 3) name restart) + (push name names-used)))) + (incf count)))))) (defvar *debug-loop-fun* #'debug-loop-fun "a function taking no parameters that starts the low-level debug loop") +;;; When the debugger is invoked due to a stepper condition, we don't +;;; want to print the current frame before the first prompt for aesthetic +;;; reasons. +(defvar *suppress-frame-print* nil) + ;;; This calls DEBUG-LOOP, performing some simple initializations ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies @@ -686,10 +715,11 @@ reset to ~S." ;;; errors. (defun internal-debug () (let ((*in-the-debugger* t) - (*read-suppress* nil)) + (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (funcall *debug-loop-fun*))) + (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition))) + (funcall *debug-loop-fun*)))) ;;;; DEBUG-LOOP @@ -700,52 +730,64 @@ reset to ~S." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") +(defun debug-read (stream) + (declare (type stream stream)) + (let* ((eof-marker (cons nil nil)) + (form (read stream nil eof-marker))) + (if (eq form eof-marker) + (abort) + form))) + (defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) - (*real-stack-top* (sb!di:top-frame)) - (*stack-top* (or *stack-top-hint* *real-stack-top*)) - (*stack-top-hint* nil) - (*current-frame* *stack-top*)) + (*real-stack-top* (sb!di:top-frame)) + (*stack-top* (or *stack-top-hint* *real-stack-top*)) + (*stack-top-hint* nil) + (*current-frame* *stack-top*)) (handler-bind ((sb!di:debug-condition - (lambda (condition) - (princ condition *debug-io*) - (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil)))) - (terpri *debug-io*) - (print-frame-call *current-frame* *debug-io* :verbosity 2) + (lambda (condition) + (princ condition *debug-io*) + (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil)))) + (cond (*suppress-frame-print* + (setf *suppress-frame-print* nil)) + (t + (terpri *debug-io*) + (print-frame-call *current-frame* *debug-io* :verbosity 2))) (loop - (catch 'debug-loop-catcher - (handler-bind ((error (lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition *debug-io*) - (format *debug-io* - "~&error flushed (because ~ + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition *debug-io*) + (format *debug-io* + "~&error flushed (because ~ ~S is set)" - '*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. - (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) - (with-simple-restart (abort - "~@" - level) - (debug-prompt *debug-io*) - (force-output *debug-io*) - (let* ((exp (read *debug-io*)) - (cmd-fun (debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format *debug-io* - "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format *debug-io* " ~A~%" ele))) - (t - (funcall cmd-fun)))))))))))) + '*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. + (let ((level *debug-command-level*) + (restart-commands (make-restart-commands))) + (flush-standard-output-streams) + (debug-prompt *debug-io*) + (force-output *debug-io*) + (let* ((exp (debug-read *debug-io*)) + (cmd-fun (debug-command-p exp restart-commands))) + (with-simple-restart (abort + "~@" + level) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format *debug-io* + "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format *debug-io* " ~A~%" ele))) + (t + (funcall cmd-fun)))))))))))) (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) @@ -765,85 +807,85 @@ reset to ~S." (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name - (symbol (sb!di:debug-fun-symbol-vars - (sb!di:frame-debug-fun *current-frame*) - name)) - (simple-string (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-fun *current-frame*) - name)))) - (location (sb!di:frame-code-location *current-frame*)) - ;; Let's only deal with valid variables. - (vars (remove-if-not (lambda (v) - (eq (sb!di:debug-var-validity v location) - :valid)) - temp))) + (symbol (sb!di:debug-fun-symbol-vars + (sb!di:frame-debug-fun *current-frame*) + name)) + (simple-string (sb!di:ambiguous-debug-vars + (sb!di:frame-debug-fun *current-frame*) + name)))) + (location (sb!di:frame-code-location *current-frame*)) + ;; Let's only deal with valid variables. + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) + temp))) (declare (list vars)) (cond ((null vars) - (error "No known valid variables match ~S." name)) - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - (t - ;; Since we have more than one, first see whether we have - ;; any variables that exactly match the specification. - (let* ((name (etypecase name - (symbol (symbol-name name)) - (simple-string name))) - ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= - ;; instead. - (exact (remove-if-not (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - name)) - vars)) - (vars (or exact vars))) - (declare (simple-string name) - (list exact vars)) - (cond - ;; Check now for only having one variable. - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - ;; If there weren't any exact matches, flame about - ;; ambiguity unless all the variables have the same - ;; name. - ((and (not exact) - (find-if-not - (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) - (cdr vars))) - (error "specification ambiguous:~%~{ ~A~%~}" - (mapcar #'sb!di:debug-var-symbol-name - (delete-duplicates - vars :test #'string= - :key #'sb!di:debug-var-symbol-name)))) - ;; All names are the same, so see whether the user - ;; ID'ed one of them. - (id-supplied - (let ((v (find id vars :key #'sb!di:debug-var-id))) - (unless v - (error - "invalid variable ID, ~W: should have been one of ~S" - id - (mapcar #'sb!di:debug-var-id vars))) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value v *current-frame*)) - (:set - `(setf (sb!di:debug-var-value v *current-frame*) - ,value-var))))) - (t - (error "Specify variable ID to disambiguate ~S. Use one of ~S." - name - (mapcar #'sb!di:debug-var-id vars))))))))) + (error "No known valid variables match ~S." name)) + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + (t + ;; Since we have more than one, first see whether we have + ;; any variables that exactly match the specification. + (let* ((name (etypecase name + (symbol (symbol-name name)) + (simple-string name))) + ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= + ;; instead. + (exact (remove-if-not (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + name)) + vars)) + (vars (or exact vars))) + (declare (simple-string name) + (list exact vars)) + (cond + ;; Check now for only having one variable. + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + ;; If there weren't any exact matches, flame about + ;; ambiguity unless all the variables have the same + ;; name. + ((and (not exact) + (find-if-not + (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + (sb!di:debug-var-symbol-name (car vars)))) + (cdr vars))) + (error "specification ambiguous:~%~{ ~A~%~}" + (mapcar #'sb!di:debug-var-symbol-name + (delete-duplicates + vars :test #'string= + :key #'sb!di:debug-var-symbol-name)))) + ;; All names are the same, so see whether the user + ;; ID'ed one of them. + (id-supplied + (let ((v (find id vars :key #'sb!di:debug-var-id))) + (unless v + (error + "invalid variable ID, ~W: should have been one of ~S" + id + (mapcar #'sb!di:debug-var-id vars))) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value v *current-frame*)) + (:set + `(setf (sb!di:debug-var-value v *current-frame*) + ,value-var))))) + (t + (error "Specify variable ID to disambiguate ~S. Use one of ~S." + name + (mapcar #'sb!di:debug-var-id vars))))))))) ) ; EVAL-WHEN @@ -883,28 +925,28 @@ reset to ~S." (defun nth-arg (count args) (let ((n count)) (dolist (ele args (error "The argument specification ~S is out of range." - n)) + n)) (lambda-list-element-dispatch ele - :required ((if (zerop n) (return (values ele t)))) - :optional ((if (zerop n) (return (values (second ele) t)))) - :keyword ((cond ((zerop n) - (return (values (second ele) nil))) - ((zerop (decf n)) - (return (values (third ele) t))))) - :deleted ((if (zerop n) (return (values ele t)))) - :rest ((let ((var (second ele))) - (lambda-var-dispatch var (sb!di:frame-code-location - *current-frame*) - (error "unused &REST argument before n'th argument") - (dolist (value - (sb!di:debug-var-value var *current-frame*) - (error - "The argument specification ~S is out of range." - n)) - (if (zerop n) - (return-from nth-arg (values value nil)) - (decf n))) - (error "invalid &REST argument before n'th argument"))))) + :required ((if (zerop n) (return (values ele t)))) + :optional ((if (zerop n) (return (values (second ele) t)))) + :keyword ((cond ((zerop n) + (return (values (second ele) nil))) + ((zerop (decf n)) + (return (values (third ele) t))))) + :deleted ((if (zerop n) (return (values ele t)))) + :rest ((let ((var (second ele))) + (lambda-var-dispatch var (sb!di:frame-code-location + *current-frame*) + (error "unused &REST argument before n'th argument") + (dolist (value + (sb!di:debug-var-value var *current-frame*) + (error + "The argument specification ~S is out of range." + n)) + (if (zerop n) + (return-from nth-arg (values value nil)) + (decf n))) + (error "invalid &REST argument before n'th argument"))))) (decf n)))) (defun arg (n) @@ -914,15 +956,15 @@ reset to ~S." pairs as separate arguments." (multiple-value-bind (var lambda-var-p) (nth-arg n (handler-case (sb!di:debug-fun-lambda-list - (sb!di:frame-debug-fun *current-frame*)) - (sb!di:lambda-list-unavailable () - (error "No argument values are available.")))) + (sb!di:frame-debug-fun *current-frame*)) + (sb!di:lambda-list-unavailable () + (error "No argument values are available.")))) (if lambda-var-p - (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) - (error "Unused arguments have no values.") - (sb!di:debug-var-value var *current-frame*) - (error "invalid argument value")) - var))) + (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) + (error "Unused arguments have no values.") + (sb!di:debug-var-value var *current-frame*) + (error "invalid argument value")) + var))) ;;;; machinery for definition of debug loop commands @@ -934,11 +976,11 @@ reset to ~S." (let ((fun-name (symbolicate name "-DEBUG-COMMAND"))) `(progn (setf *debug-commands* - (remove ,name *debug-commands* :key #'car :test #'string=)) + (remove ,name *debug-commands* :key #'car :test #'string=)) (defun ,fun-name ,args - (unless *in-the-debugger* - (error "invoking debugger command while outside the debugger")) - ,@body) + (unless *in-the-debugger* + (error "invoking debugger command while outside the debugger")) + ,@body) (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) @@ -958,38 +1000,38 @@ reset to ~S." (defun debug-command-p (form &optional other-commands) (if (or (symbolp form) (integerp form)) (let* ((name - (if (symbolp form) - (symbol-name form) - (format nil "~W" form))) - (len (length name)) - (res nil)) - (declare (simple-string name) - (fixnum len) - (list res)) - - ;; Find matching commands, punting if exact match. - (flet ((match-command (ele) - (let* ((str (car ele)) - (str-len (length str))) - (declare (simple-string str) - (fixnum str-len)) - (cond ((< str-len len)) - ((= str-len len) - (when (string= name str :end1 len :end2 len) - (return-from debug-command-p (cdr ele)))) - ((string= name str :end1 len :end2 len) - (push ele res)))))) - (mapc #'match-command *debug-commands*) - (mapc #'match-command other-commands)) - - ;; Return the right value. - (cond ((not res) nil) - ((= (length res) 1) - (cdar res)) - (t ; Just return the names. - (do ((cmds res (cdr cmds))) - ((not cmds) res) - (setf (car cmds) (caar cmds)))))))) + (if (symbolp form) + (symbol-name form) + (format nil "~W" form))) + (len (length name)) + (res nil)) + (declare (simple-string name) + (fixnum len) + (list res)) + + ;; Find matching commands, punting if exact match. + (flet ((match-command (ele) + (let* ((str (car ele)) + (str-len (length str))) + (declare (simple-string str) + (fixnum str-len)) + (cond ((< str-len len)) + ((= str-len len) + (when (string= name str :end1 len :end2 len) + (return-from debug-command-p (cdr ele)))) + ((string= name str :end1 len :end2 len) + (push ele res)))))) + (mapc #'match-command *debug-commands*) + (mapc #'match-command other-commands)) + + ;; Return the right value. + (cond ((not res) nil) + ((= (length res) 1) + (cdar res)) + (t ; Just return the names. + (do ((cmds res (cdr cmds))) + ((not cmds) res) + (setf (car cmds) (caar cmds)))))))) ;;; Return a list of debug commands (in the same format as ;;; *DEBUG-COMMANDS*) that invoke each active restart. @@ -999,15 +1041,15 @@ reset to ~S." ;;; restart of the same name, or it is NIL). (defun make-restart-commands (&optional (restarts *debug-restarts*)) (let ((commands) - (num 0)) ; better be the same as show-restarts! + (num 0)) ; better be the same as show-restarts! (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun (lambda () - (/show0 "in restart-command closure, about to i-r-i") - (invoke-restart-interactively restart)))) + (/show0 "in restart-command closure, about to i-r-i") + (invoke-restart-interactively restart)))) (push (cons (prin1-to-string num) restart-fun) commands) - (unless (or (null (restart-name restart)) + (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) (push (cons name restart-fun) commands)))) (incf num)) @@ -1018,18 +1060,18 @@ reset to ~S." (!def-debug-command "UP" () (let ((next (sb!di:frame-up *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next *debug-io*)) - (t - (format *debug-io* "~&Top of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Top of stack."))))) (!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next *debug-io*)) - (t - (format *debug-io* "~&Bottom of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Bottom of stack."))))) (!def-debug-command-alias "D" "DOWN") @@ -1043,23 +1085,23 @@ reset to ~S." (!def-debug-command-alias "B" "BOTTOM") (!def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "frame number: "))) + (n (read-prompting-maybe "frame number: "))) (setf *current-frame* - (multiple-value-bind (next-frame-fun limit-string) - (if (< n (sb!di:frame-number *current-frame*)) - (values #'sb!di:frame-up "top") - (values #'sb!di:frame-down "bottom")) - (do ((frame *current-frame*)) - ((= n (sb!di:frame-number frame)) - frame) - (let ((next-frame (funcall next-frame-fun frame))) - (cond (next-frame - (setf frame next-frame)) - (t - (format *debug-io* - "The ~A of the stack was encountered.~%" - limit-string) - (return frame))))))) + (multiple-value-bind (next-frame-fun limit-string) + (if (< n (sb!di:frame-number *current-frame*)) + (values #'sb!di:frame-up "top") + (values #'sb!di:frame-down "bottom")) + (do ((frame *current-frame*)) + ((= n (sb!di:frame-number frame)) + frame) + (let ((next-frame (funcall next-frame-fun frame))) + (cond (next-frame + (setf frame next-frame)) + (t + (format *debug-io* + "The ~A of the stack was encountered.~%" + limit-string) + (return frame))))))) (print-frame-call *current-frame* *debug-io*)) (!def-debug-command-alias "F" "FRAME") @@ -1077,25 +1119,25 @@ reset to ~S." (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) - (write-string "restart: ") - (force-output) + (write-string "restart: " *debug-io*) + (force-output *debug-io*) (setf num (read *debug-io*))) (let ((restart (typecase num - (unsigned-byte - (nth num *debug-restarts*)) - (symbol - (find num *debug-restarts* :key #'restart-name - :test (lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) - (t - (format *debug-io* "~S is invalid as a restart name.~%" + (unsigned-byte + (nth num *debug-restarts*)) + (symbol + (find num *debug-restarts* :key #'restart-name + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) + (t + (format *debug-io* "~S is invalid as a restart name.~%" num) - (return-from restart-debug-command nil))))) + (return-from restart-debug-command nil))))) (/show0 "got RESTART") (if restart - (invoke-restart-interactively restart) - (princ "There is no such restart." *debug-io*))))) + (invoke-restart-interactively restart) + (princ "There is no such restart." *debug-io*))))) ;;;; information commands @@ -1106,9 +1148,9 @@ reset to ~S." ;; desperate holdout is running this on a dumb terminal somewhere, ;; we tell him where to find the message stored as a string. (format *debug-io* - "~&~A~2%(The HELP string is stored in ~S.)~%" - *debug-help-string* - '*debug-help-string*)) + "~&~A~2%(The HELP string is stored in ~S.)~%" + *debug-help-string* + '*debug-help-string*)) (!def-debug-command-alias "?" "HELP") @@ -1127,35 +1169,35 @@ reset to ~S." (!def-debug-command "LIST-LOCALS" () (let ((d-fun (sb!di:frame-debug-fun *current-frame*))) (if (sb!di:debug-var-info-available d-fun) - (let ((*standard-output* *debug-io*) - (location (sb!di:frame-code-location *current-frame*)) - (prefix (read-if-available nil)) - (any-p nil) - (any-valid-p nil)) - (dolist (v (sb!di:ambiguous-debug-vars - 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) - (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*)))) - - (cond - ((not any-p) - (format *debug-io* + (let ((*standard-output* *debug-io*) + (location (sb!di:frame-code-location *current-frame*)) + (prefix (read-if-available nil)) + (any-p nil) + (any-valid-p nil)) + (dolist (v (sb!di:ambiguous-debug-vars + 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) + (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*)))) + + (cond + ((not any-p) + (format *debug-io* "There are no local variables ~@[starting with ~A ~]~ in the function." - prefix)) - ((not any-valid-p) - (format *debug-io* + prefix)) + ((not any-valid-p) + (format *debug-io* "All variables ~@[starting with ~A ~]currently ~ have invalid values." - prefix)))) - (write-line "There is no variable information available." + prefix)))) + (write-line "There is no variable information available." *debug-io*)))) (!def-debug-command-alias "L" "LIST-LOCALS") @@ -1190,8 +1232,8 @@ reset to ~S." ;;; Stuff to clean up before saving a core (defun debug-deinit () (setf *cached-debug-source* nil - *cached-source-stream* nil - *cached-readtable* 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 @@ -1207,47 +1249,47 @@ reset to ~S." (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 - (ecase (sb!di:debug-source-from d-source) - (:file (get-file-toplevel-form location)) - (:lisp (svref (sb!di:debug-source-name d-source) offset))))) - (setq *cached-toplevel-form-offset* offset) - (values (setq *cached-form-number-translations* - (sb!di:form-number-translations res offset)) - (setq *cached-toplevel-form* res)))))) + (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 + (ecase (sb!di:debug-source-from d-source) + (:file (get-file-toplevel-form location)) + (:lisp (svref (sb!di:debug-source-name d-source) offset))))) + (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-name d-source))) + (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-name 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))) + (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) @@ -1256,71 +1298,97 @@ reset to ~S." (format *debug-io* "~%; File has been modified since compilation:~%; ~A~@ ; Using form offset instead of character position.~%" - (namestring name)) + (namestring name)) (file-position *cached-source-stream* 0) (let ((*read-suppress* t)) - (dotimes (i local-tlf-offset) - (read *cached-source-stream*))))) + (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))) + (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))) + (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.")) + (error "The source path no longer exists.")) (sb!di:source-path-context form (svref translations form-num) context)))) -;;; step to the next steppable form -(!def-debug-command "STEP" () - (let ((restart (find-restart 'continue *debug-condition*))) - (cond (restart - (setf *stepping* t - *step* t) - (invoke-restart restart)) - (t - (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) + +;;; start single-stepping +(!def-debug-command "START" () + (if (typep *debug-condition* 'step-condition) + (format *debug-io* "~&Already single-stepping.~%") + (let ((restart (find-restart 'continue *debug-condition*))) + (cond (restart + (sb!impl::enable-stepping) + (invoke-restart restart)) + (t + (format *debug-io* "~&Non-continuable error, cannot start stepping.~%")))))) + +(defmacro def-step-command (command-name restart-name) + `(!def-debug-command ,command-name () + (if (typep *debug-condition* 'step-condition) + (let ((restart (find-restart ',restart-name *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))) + +(def-step-command "STEP" step-into) +(def-step-command "NEXT" step-next) +(def-step-command "STOP" step-continue) + +(!def-debug-command-alias "S" "STEP") +(!def-debug-command-alias "N" "NEXT") + +(!def-debug-command "OUT" () + (if (typep *debug-condition* 'step-condition) + (if sb!impl::*step-out* + (let ((restart (find-restart 'step-out *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%")) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))) ;;; miscellaneous commands (!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) - (debug-fun (sb!di:code-location-debug-fun curloc)) - (function (sb!di:debug-fun-fun debug-fun))) + (debug-fun (sb!di:code-location-debug-fun curloc)) + (function (sb!di:debug-fun-fun debug-fun))) (if function - (describe function) - (format *debug-io* "can't figure out the function for this frame")))) + (describe function) + (format *debug-io* "can't figure out the function for this frame")))) (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) (!def-debug-command "RETURN" (&optional - (return (read-prompting-maybe - "return: "))) + (return (read-prompting-maybe + "return: "))) (let ((tag (find-if (lambda (x) - (and (typep (car x) 'symbol) - (not (symbol-package (car x))) - (string= (car x) "SB-DEBUG-CATCH-TAG"))) - (sb!di::frame-catches *current-frame*)))) + (and (typep (car x) 'symbol) + (not (symbol-package (car x))) + (string= (car x) "SB-DEBUG-CATCH-TAG"))) + (sb!di::frame-catches *current-frame*)))) (if tag - (throw (car tag) - (funcall (sb!di:preprocess-for-eval - return - (sb!di:frame-code-location *current-frame*)) - *current-frame*)) - (format *debug-io* + (throw (car tag) + (funcall (sb!di:preprocess-for-eval + return + (sb!di:frame-code-location *current-frame*)) + *current-frame*)) + (format *debug-io* "~@"))))