X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=b7709e1fe6e042d7205e83451d72acb0d8ef1a6f;hb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;hp=5105bb4024070d16f99f559c9ef3d415a4582999;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 5105bb4..b7709e1 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!DEBUG") - -(file-comment - "$Header$") ;;;; variables and constants @@ -25,10 +22,10 @@ "*PRINT-LENGTH* for the debugger") (defvar *debug-readtable* - ;; KLUDGE: This can't be initialized in a cold toplevel form, because the - ;; *STANDARD-READTABLE* isn't initialized until after cold toplevel forms - ;; have run. So instead we initialize it immediately after - ;; *STANDARD-READTABLE*. -- WHN 20000205 + ;; KLUDGE: This can't be initialized in a cold toplevel form, + ;; because the *STANDARD-READTABLE* isn't initialized until after + ;; cold toplevel forms have run. So instead we initialize it + ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205 nil #!+sb-doc "*READTABLE* for the debugger") @@ -37,9 +34,8 @@ #!+sb-doc "This is T while in the debugger.") -(defvar *debug-command-level* 0 - #!+sb-doc - "Pushes and pops/exits inside the debugger change this.") +;;; nestedness inside debugger command loops +(defvar *debug-command-level* 0) (defvar *stack-top-hint* nil #!+sb-doc @@ -50,44 +46,43 @@ (defvar *current-frame* nil) -;;; the default for *DEBUG-PROMPT* -(defun debug-prompt () - (let ((*standard-output* *debug-io*)) - (terpri) - (prin1 (sb!di:frame-number *current-frame*)) - (dotimes (i *debug-command-level*) (princ "]")) - (princ " ") - (force-output))) - -(defparameter *debug-prompt* #'debug-prompt - #!+sb-doc - "a function of no arguments that prints the debugger prompt on *DEBUG-IO*") - +(defun debug-prompt (stream) + + ;; old behavior, will probably go away in sbcl-0.7.x + (format stream "~%~D" (sb!di:frame-number *current-frame*)) + (dotimes (i *debug-command-level*) + (write-char #\] stream)) + (write-char #\space stream) + + ;; planned new behavior, delayed since it will break ILISP + #+nil + (format stream + "~%~D~:[~;[~D~]] " + (sb!di:frame-number *current-frame*) + (> *debug-command-level* 1) + *debug-command-level*)) + (defparameter *debug-help-string* "The prompt is right square brackets, the number indicating how many recursive command loops you are in. Any command may be uniquely abbreviated. -The debugger rebinds various special variables for controlling i/o, - sometimes to defaults (a la WITH-STANDARD-IO-SYNTAX) and sometimes to - its own values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*. +The debugger rebinds various special variables for controlling i/o, sometimes + to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to + its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*. Debug commands do not affect * and friends, but evaluation in the debug loop - do affect these variables. + does affect these variables. SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt drop you into deeper into the debugger. Getting in and out of the debugger: - Q throws to top level. - GO calls CONTINUE which tries to proceed with the restart 'CONTINUE. RESTART invokes restart numbered as shown (prompt if not given). ERROR prints the error condition and restart cases. - The name of any restart, or its number, is a valid command, and is the same as using RESTART to invoke that restart. Changing frames: - U up frame D down frame - T top frame B bottom frame - F n frame n + U up frame D down frame + B bottom frame F n frame n (n=0 for top frame) Inspecting frames: BACKTRACE [n] shows n frames going down the stack. @@ -96,8 +91,8 @@ Inspecting frames: SOURCE [n] displays frame's source form with n levels of enclosing forms. Breakpoints and steps: - LIST-LOCATIONS [{function | :c}] List the locations for breakpoints. - Specify :c for the current frame. + LIST-LOCATIONS [{function | :C}] List the locations for breakpoints. + Specify :C for the current frame. Abbreviation: LL LIST-BREAKPOINTS List the active breakpoints. Abbreviations: LB, LBP @@ -493,10 +488,10 @@ Function and macro commands: s))))) string) -;;; Print frame with verbosity level 1. If we hit a rest-arg, then +;;; Print FRAME with verbosity level 1. 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. +;;; &REST arg's list of values. (defun print-frame-call-1 (frame) (let* ((d-fun (sb!di:frame-debug-function frame)) (loc (sb!di:frame-code-location frame)) @@ -517,12 +512,15 @@ Function and macro commands: (second ele) frame)) results)) (return)) - (push (make-unprintable-object "unavailable &REST arg") + (push (make-unprintable-object + "unavailable &REST argument") results))))) (sb!di:lambda-list-unavailable () (push (make-unprintable-object "lambda list unavailable") results))) - (prin1 (mapcar #'ensure-printable-object (nreverse results))) + (pprint-logical-block (*standard-output* nil) + (let ((x (nreverse (mapcar #'ensure-printable-object results)))) + (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x)))) (when (sb!di:debug-function-kind d-fun) (write-char #\[) (prin1 (sb!di:debug-function-kind d-fun)) @@ -539,12 +537,12 @@ Function and macro commands: (defun frame-call-arg (var location frame) (lambda-var-dispatch var location - (make-unprintable-object "unused arg") + (make-unprintable-object "unused argument") (sb!di:debug-var-value var frame) - (make-unprintable-object "unavailable arg"))) + (make-unprintable-object "unavailable argument"))) -;;; Prints a representation of the function call causing frame to -;;; exist. Verbosity indicates the level of information to output; +;;; Prints a representation of the function call causing FRAME to +;;; exist. VERBOSITY indicates the level of information to output; ;;; zero indicates just printing the debug-function's name, and one ;;; indicates displaying call-like, one-liner format with argument ;;; values. @@ -582,37 +580,55 @@ Function and macro commands: (defvar *debug-restarts*) (defvar *debug-condition*) +;;; Print *DEBUG-CONDITION*, taking care to avoid recursive invocation +;;; of the debugger in case of a problem (e.g. a bug in the PRINT-OBJECT +;;; method for *DEBUG-CONDITION*). +(defun princ-debug-condition-carefully (stream) + (handler-case (princ *debug-condition* stream) + (error (condition) + (format stream + " (caught ~S when trying to print ~S)" + (type-of condition) + '*debug-condition*))) + *debug-condition*) + (defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." (let ((old-hook *debugger-hook*)) (when old-hook (let ((*debugger-hook* nil)) - (funcall hook condition hook)))) + (funcall old-hook condition old-hook)))) (sb!unix:unix-sigsetmask 0) - (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX + + ;; 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*)) + (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX. + (original-package *package*)) (with-standard-io-syntax (let* ((*debug-condition* condition) (*debug-restarts* (compute-restarts condition)) - ;; FIXME: The next two bindings seem flaky, violating the - ;; principle of least surprise. But in order to fix them, we'd - ;; need to go through all the i/o statements in the debugger, - ;; since a lot of them do their thing on *STANDARD-INPUT* and - ;; *STANDARD-OUTPUT* instead of *DEBUG-IO*. - (*standard-input* *debug-io*) ; in case of setq - (*standard-output* *debug-io*) ; '' '' '' '' - ;; We also want to set the i/o subsystem into a known, useful - ;; state, regardless of where in the debugger was invoked in the - ;; program. WITH-STANDARD-IO-SYNTAX does some of that, but - ;; 1. It doesn't affect our internal special variables like - ;; *CURRENT-LEVEL*. + ;; We want the i/o subsystem to be in a known, useful + ;; state, regardless of where the debugger was invoked in + ;; the program. WITH-STANDARD-IO-SYNTAX does some of that, + ;; but + ;; 1. It doesn't affect our internal special variables + ;; like *CURRENT-LEVEL*. ;; 2. It isn't customizable. - ;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* to the - ;; same value as the toplevel default. + ;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* + ;; to the same value as the toplevel default. ;; 4. It sets *PACKAGE* to COMMON-LISP-USER, which is not ;; helpful behavior for a debugger. - ;; We try to remedy all these problems with explicit rebindings - ;; here. + ;; We try to remedy all these problems with explicit + ;; rebindings here. (sb!kernel:*current-level* 0) (*print-length* *debug-print-length*) (*print-level* *debug-print-level*) @@ -620,19 +636,59 @@ Function and macro commands: (*print-readably* nil) (*print-pretty* t) (*package* original-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, and get confused. + (flush-standard-output-streams) + + ;; 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&debugger invoked on ~S of type ~S:~% ~A~%" - '*debug-condition* - (type-of *debug-condition*) - *debug-condition*) - (let (;; FIXME: like the bindings of *STANDARD-INPUT* and - ;; *STANDARD-OUTPUT* above.. + "~2&debugger invoked on condition of type ~S:~% " + (type-of *debug-condition*)) + (princ-debug-condition-carefully *error-output*) + (terpri *error-output*) + + ;; After the initial error/condition/whatever announcement to + ;; *ERROR-OUTPUT*, we become interactive, and should talk on + ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative + ;; statement, not a description of reality.:-| There's a lot of + ;; older debugger code which was written to do i/o on whatever + ;; stream was in fashion at the time, and not all of it has + ;; been converted to behave this way. -- WHN 2000-11-16) + (let (;; FIXME: The first two bindings here seem wrong, + ;; violating the principle of least surprise, and making + ;; it impossible for the user to do reasonable things + ;; like using PRINT at the debugger prompt to send output + ;; to the program's ordinary (possibly + ;; redirected-to-a-file) *STANDARD-OUTPUT*, or using + ;; PEEK-CHAR or some such thing on the program's ordinary + ;; (possibly also redirected) *STANDARD-INPUT*. + (*standard-input* *debug-io*) + (*standard-output* *debug-io*) + ;; 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) - (show-restarts *debug-restarts* *error-output*)) + (format *debug-io* + "~%~@~2%" + '*debug-condition*) + (show-restarts *debug-restarts* *debug-io*) + (terpri *debug-io*)) (internal-debug)))))) -(defun show-restarts (restarts &optional (s *error-output*)) +(defun show-restarts (restarts s) (when restarts (format s "~&restarts:~%") (let ((count 0) @@ -656,18 +712,17 @@ Function and macro commands: (push name names-used)))) (incf count))))) -;;; This calls DEBUG-LOOP, performing some simple initializations before doing -;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger. -;;; SB!CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug -;;; prompt as quickly as possible with as little risk as possible for stepping -;;; on whatever is causing recursive errors. +;;; 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 +;;; to get into a debug prompt as quickly as possible with as little +;;; risk as possible for stepping on whatever is causing recursive +;;; errors. (defun internal-debug () (let ((*in-the-debugger* t) (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) - (clear-input *debug-io*) - (format *debug-io* - "~&Within the debugger, you can type HELP for help.~%")) + (clear-input *debug-io*)) #!-mp (debug-loop) #!+mp (sb!mp:without-scheduling (debug-loop)))) @@ -708,8 +763,11 @@ Function and macro commands: ;; WITH-SIMPLE-RESTART. (let ((level *debug-command-level*) (restart-commands (make-restart-commands))) - (with-simple-restart (abort "Return to debug level ~D." level) - (funcall *debug-prompt*) + (with-simple-restart (abort + "Reduce debugger level (to debug level ~D)." + level) + (debug-prompt *debug-io*) + (force-output *debug-io*) (let ((input (sb!int:get-stream-command *debug-io*))) (cond (input (let ((cmd-fun (debug-command-p @@ -763,9 +821,7 @@ Function and macro commands: (unless (boundp '*) (setq * nil) (fresh-line) - ;; FIXME: Perhaps this shouldn't be WARN (for fear of complicating - ;; the debugging situation?) but at least it should go to *ERROR-OUTPUT*. - ;; (And probably it should just be WARN.) + ;; FIXME: The way INTERACTIVE-EVAL does this seems better. (princ "Setting * to NIL (was unbound marker).")))) ;;;; debug loop functions @@ -823,8 +879,9 @@ Function and macro commands: (: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. + ;; 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) @@ -836,8 +893,8 @@ Function and macro commands: (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. + ;; 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 @@ -879,11 +936,11 @@ Function and macro commands: (defun (setf var) (value name &optional (id 0 id-supplied)) (define-var-operation :set value)) -;;; This returns the COUNT'th arg as the user sees it from args, the result of -;;; SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential -;;; DEBUG-VAR from the lambda-list, then the second value is T. If this -;;; returns a keyword symbol or a value from a rest arg, then the second value -;;; is NIL. +;;; This returns the COUNT'th arg as the user sees it from args, the +;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a +;;; potential DEBUG-VAR from the lambda-list, then the second value is +;;; T. If this returns a keyword symbol or a value from a rest arg, +;;; then the second value is NIL. (declaim (ftype (function (index list)) nth-arg)) (defun nth-arg (count args) (let ((n count)) @@ -900,7 +957,7 @@ Function and macro commands: :rest ((let ((var (second ele))) (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) - (error "unused REST-arg before n'th argument") + (error "unused &REST argument before n'th argument") (dolist (value (sb!di:debug-var-value var *current-frame*) (error @@ -909,7 +966,7 @@ Function and macro commands: (if (zerop n) (return-from nth-arg (values value nil)) (decf n))) - (error "invalid REST-arg before n'th argument"))))) + (error "invalid &REST argument before n'th argument"))))) (decf n)))) (defun arg (n) @@ -1037,12 +1094,15 @@ Function and macro commands: (def-debug-command-alias "D" "DOWN") -(def-debug-command "TOP" () - (do ((prev *current-frame* lead) - (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead))) - ((null lead) - (setf *current-frame* prev) - (print-frame-call prev)))) +;;; CMU CL had this command, but SBCL doesn't, since +;;; it's redundant with "FRAME 0", and it interferes with abbreviations +;;; for the TOPLEVEL restart. +;;;(def-debug-command "TOP" () +;;; (do ((prev *current-frame* lead) +;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead))) +;;; ((null lead) +;;; (setf *current-frame* prev) +;;; (print-frame-call prev)))) (def-debug-command "BOTTOM" () (do ((prev *current-frame* lead) @@ -1077,17 +1137,25 @@ Function and macro commands: ;;;; commands for entering and leaving the debugger -(def-debug-command "QUIT" () - (throw 'sb!impl::top-level-catcher nil)) +;;; CMU CL supported this QUIT debug command, but SBCL provides this +;;; functionality with a restart instead. (The QUIT debug command was +;;; removed because it's confusing to have "quit" mean two different +;;; things in the system, "restart the top level REPL" in the debugger +;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.) +;;; +;;;(def-debug-command "QUIT" () +;;; (throw 'sb!impl::top-level-catcher nil)) -(def-debug-command "GO" () - (continue *debug-condition*) - (error "There is no restart named CONTINUE.")) +;;; CMU CL supported this GO debug command, but SBCL doesn't -- just +;;; type the CONTINUE restart name. +;;;(def-debug-command "GO" () +;;; (continue *debug-condition*) +;;; (error "There is no restart named CONTINUE.")) (def-debug-command "RESTART" () (let ((num (read-if-available :prompt))) (when (eq num :prompt) - (show-restarts *debug-restarts*) + (show-restarts *debug-restarts* *debug-io*) (write-string "restart: ") (force-output) (setf num (read *standard-input*))) @@ -1126,8 +1194,8 @@ Function and macro commands: (def-debug-command-alias "?" "HELP") (def-debug-command "ERROR" () - (format t "~A~%" *debug-condition*) - (show-restarts *debug-restarts*)) + (format *debug-io* "~A~%" *debug-condition*) + (show-restarts *debug-restarts* *debug-io*)) (def-debug-command "BACKTRACE" () (backtrace (read-if-available most-positive-fixnum))) @@ -1177,8 +1245,9 @@ Function and macro commands: ;;;; 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. +;;; 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 @@ -1201,16 +1270,17 @@ Function and macro commands: *cached-readtable* nil)) sb!int:*before-save-initializations*) -;;; We also cache the last top-level form that we printed a source for so that -;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS. +;;; We also cache the last top-level 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-top-level-form-offset* nil) (declaim (type (or index null) *cached-top-level-form-offset*)) (defvar *cached-top-level-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. +;;; 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-top-level-form (location) (let ((d-source (sb!di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) @@ -1227,9 +1297,9 @@ Function and macro commands: (sb!di:form-number-translations res offset)) (setq *cached-top-level-form* res)))))) -;;; Locates the source file (if it still exists) and grabs the top-level form. -;;; If the file is modified, we use the top-level-form offset instead of the -;;; recorded character offset. +;;; 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-top-level-form (location) (let* ((d-source (sb!di:code-location-debug-source location)) (tlf-offset (sb!di:code-location-top-level-form-offset location)) @@ -1298,9 +1368,10 @@ Function and macro commands: (continue *debug-condition*) (error "couldn't continue")) -;;; List possible breakpoint locations, which ones are active, and where GO -;;; will continue. Set *POSSIBLE-BREAKPOINTS* to the code-locations which can -;;; then be used by sbreakpoint. +;;; List possible breakpoint locations, which ones are active, and +;;; where the CONTINUE restart will transfer control. Set +;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be +;;; used by sbreakpoint. (def-debug-command "LIST-LOCATIONS" () (let ((df (read-if-available *default-breakpoint-debug-function*))) (cond ((consp df)