X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=a5fd549bfda2147a69134a012dbf694b6c1897f7;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=ea374d10fb65a2acf80b5f16a86456148e7ff777;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index ea374d1..a5fd549 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -37,15 +37,22 @@ ;;; nestedness inside debugger command loops (defvar *debug-command-level* 0) -(defvar *stack-top-hint* nil - #!+sb-doc - "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. +(defvar *stack-top-hint* nil) + (defvar *stack-top* nil) (defvar *real-stack-top* nil) (defvar *current-frame* nil) +;;; Beginner-oriented help messages are important because you end up +;;; in the debugger whenever something bad happens, or if you try to +;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever. +;;; But after memorizing them the wasted screen space gets annoying.. +(defvar *debug-beginner-help-p* t + "Should the debugger display beginner-oriented help messages?") + (defun debug-prompt (stream) ;; old behavior, will probably go away in sbcl-0.7.x @@ -253,7 +260,7 @@ Function and macro commands: :type (or sb!di:code-location sb!di:debug-function)) ;; the breakpoint returned by sb!di:make-breakpoint (breakpoint (required-argument) :type sb!di:breakpoint) - ;; the function returned from sb!di:preprocess-for-eval. If result is + ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is ;; non-NIL, drop into the debugger. (break #'identity :type function) ;; the function returned from sb!di:preprocess-for-eval. If result is @@ -432,7 +439,7 @@ Function and macro commands: (*standard-output* *debug-io*)) #!+sb-doc "Show a listing of the call stack going down from the current frame. In the - debugger, the current frame is indicated by the prompt. Count is how many + debugger, the current frame is indicated by the prompt. COUNT is how many frames to show." (fresh-line *standard-output*) (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame)) @@ -582,18 +589,6 @@ 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." @@ -645,16 +640,22 @@ reset to ~S." ;; the last line of output or so, and get confused. (flush-standard-output-streams) - ;; The initial output here goes to *ERROR-OUTPUT*, because the + ;; (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 condition of type ~S:~% " - (type-of *debug-condition*)) - (princ-debug-condition-carefully *error-output*) - (terpri *error-output*) + ;; regardless of what the debugger does afterwards.) + (handler-case + (format *error-output* + "~2&~@~%" + (type-of *debug-condition*) + *debug-condition*) + (error (condition) + (format *error-output* + "~&(caught ~S trying to print ~S when entering debugger)~%" + (type-of condition) + '*debug-condition*))) ;; After the initial error/condition/whatever announcement to ;; *ERROR-OUTPUT*, we become interactive, and should talk on @@ -679,15 +680,17 @@ reset to ~S." ;; that file, and right to send them to *DEBUG-IO*. (*error-output* *debug-io*)) (unless (typep condition 'step-condition) - (format *debug-io* - "~%~@~2%" - '*debug-condition*) - (show-restarts *debug-restarts* *debug-io*) - (terpri *debug-io*)) + (when *debug-beginner-help-p* + (format *debug-io* + "~%~@~2%" + '*debug-condition* + '*debug-beginner-help-p*)) + (show-restarts *debug-restarts* *debug-io*)) (internal-debug)))))) (defun show-restarts (restarts s) @@ -798,32 +801,12 @@ reset to ~S." (t (funcall cmd-fun))))))))))))))) -;;; FIXME: As far as I know, the CMU CL X86 codebase has never -;;; supported access to the environment of the debugged function. It -;;; would be really, really nice to make that work! (Until then, -;;; non-NIL *AUTO-EVAL-IN-FRAME* seems to be useless, and as of -;;; sbcl-0.6.10 it even seemed to be actively harmful, since the -;;; debugger gets confused when trying to unwind the frames which -;;; arise in SIGINT interrupts. So it's set to NIL.) -(defvar *auto-eval-in-frame* nil - #!+sb-doc - "When set, evaluations in the debugger's command loop occur relative - to the current frame's environment without the need of debugger - forms that explicitly control this kind of evaluation. In an ideal - world, the default would be T, but since unfortunately the X86 - debugger support isn't good enough to make this useful, the - default is NIL instead.") - ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) (/noshow (fboundp 'compile)) - (/noshow (and (fboundp 'compile) *auto-eval-in-frame*)) (setq +++ ++ ++ + + - - expr) - (let* ((values (multiple-value-list - (if (and (fboundp 'compile) *auto-eval-in-frame*) - (sb!di:eval-in-frame *current-frame* -) - (eval -)))) + (let* ((values (multiple-value-list (eval -))) (*standard-output* *debug-io*)) (/noshow "done with EVAL in DEBUG-EVAL-PRINT") (fresh-line) @@ -1011,10 +994,8 @@ argument") ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are ;;; permitted. -;;; -;;; FIXME: This is not needed in the target Lisp system. -(defmacro def-debug-command (name args &rest body) - (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND")))) +(defmacro !def-debug-command (name args &rest body) + (let ((fun-name (symbolicate name "-DEBUG-COMMAND"))) `(progn (setf *debug-commands* (remove ,name *debug-commands* :key #'car :test #'string=)) @@ -1025,7 +1006,7 @@ argument") (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) -(defun def-debug-command-alias (new-name existing-name) +(defun !def-debug-command-alias (new-name existing-name) (let ((pair (assoc existing-name *debug-commands* :test #'string=))) (unless pair (error "unknown debug command name: ~S" existing-name)) (push (cons new-name (cdr pair)) *debug-commands*)) @@ -1096,7 +1077,7 @@ argument") ;;;; frame-changing commands -(def-debug-command "UP" () +(!def-debug-command "UP" () (let ((next (sb!di:frame-up *current-frame*))) (cond (next (setf *current-frame* next) @@ -1104,7 +1085,7 @@ argument") (t (format t "~&Top of stack."))))) -(def-debug-command "DOWN" () +(!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next (setf *current-frame* next) @@ -1112,29 +1093,29 @@ argument") (t (format t "~&Bottom of stack."))))) -(def-debug-command-alias "D" "DOWN") +(!def-debug-command-alias "D" "DOWN") ;;; 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" () +;;;(!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" () +(!def-debug-command "BOTTOM" () (do ((prev *current-frame* lead) (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead))) ((null lead) (setf *current-frame* prev) (print-frame-call prev)))) -(def-debug-command-alias "B" "BOTTOM") +(!def-debug-command-alias "B" "BOTTOM") -(def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "frame number: "))) +(!def-debug-command "FRAME" (&optional + (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*)) @@ -1153,7 +1134,7 @@ argument") (return frame))))))) (print-frame-call *current-frame*)) -(def-debug-command-alias "F" "FRAME") +(!def-debug-command-alias "F" "FRAME") ;;;; commands for entering and leaving the debugger @@ -1163,16 +1144,18 @@ argument") ;;; 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" () +;;;(!def-debug-command "QUIT" () ;;; (throw 'sb!impl::top-level-catcher nil)) -;;; CMU CL supported this GO debug command, but SBCL doesn't -- just -;;; type the CONTINUE restart name. -;;;(def-debug-command "GO" () +;;; CMU CL supported this GO debug command, but SBCL doesn't -- in +;;; SBCL you just type the CONTINUE restart name instead (or "RESTART +;;; CONTINUE", that's OK too). + +;;;(!def-debug-command "GO" () ;;; (continue *debug-condition*) ;;; (error "There is no restart named CONTINUE.")) -(def-debug-command "RESTART" () +(!def-debug-command "RESTART" () (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) @@ -1200,32 +1183,32 @@ argument") ;;;; information commands -(def-debug-command "HELP" () +(!def-debug-command "HELP" () ;; CMU CL had a little toy pager here, but "if you aren't running ;; ILISP (or a smart windowing system, or something) you deserve to ;; lose", so we've dropped it in SBCL. However, in case some ;; 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.)~%" + "~&~A~2%(The HELP string is stored in ~S.)~%" *debug-help-string* '*debug-help-string*)) -(def-debug-command-alias "?" "HELP") +(!def-debug-command-alias "?" "HELP") -(def-debug-command "ERROR" () +(!def-debug-command "ERROR" () (format *debug-io* "~A~%" *debug-condition*) (show-restarts *debug-restarts* *debug-io*)) -(def-debug-command "BACKTRACE" () +(!def-debug-command "BACKTRACE" () (backtrace (read-if-available most-positive-fixnum))) -(def-debug-command "PRINT" () +(!def-debug-command "PRINT" () (print-frame-call *current-frame*)) -(def-debug-command-alias "P" "PRINT") +(!def-debug-command-alias "P" "PRINT") -(def-debug-command "LIST-LOCALS" () +(!def-debug-command "LIST-LOCALS" () (let ((d-fun (sb!di:frame-debug-function *current-frame*))) (if (sb!di:debug-var-info-available d-fun) (let ((*standard-output* *debug-io*) @@ -1256,9 +1239,9 @@ argument") prefix)))) (write-line "There is no variable information available.")))) -(def-debug-command-alias "L" "LIST-LOCALS") +(!def-debug-command-alias "L" "LIST-LOCALS") -(def-debug-command "SOURCE" () +(!def-debug-command "SOURCE" () (fresh-line) (print-code-location-source-form (sb!di:frame-code-location *current-frame*) (read-if-available 0))) @@ -1285,10 +1268,10 @@ argument") (defvar *cached-readtable* nil) (declaim (type (or readtable null) *cached-readtable*)) -(pushnew #'(lambda () - (setq *cached-debug-source* nil *cached-source-stream* nil - *cached-readtable* nil)) - sb!int:*before-save-initializations*) +(pushnew (lambda () + (setq *cached-debug-source* nil *cached-source-stream* nil + *cached-readtable* nil)) + *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 @@ -1382,7 +1365,7 @@ argument") ;;; breakpoint and step commands ;;; Step to the next code-location. -(def-debug-command "STEP" () +(!def-debug-command "STEP" () (setf *number-of-steps* (read-if-available 1)) (set-step-breakpoint *current-frame*) (continue *debug-condition*) @@ -1392,7 +1375,7 @@ argument") ;;; 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" () +(!def-debug-command "LIST-LOCATIONS" () (let ((df (read-if-available *default-breakpoint-debug-function*))) (cond ((consp df) (setf df (sb!di:function-debug-function (eval df))) @@ -1453,10 +1436,10 @@ argument") :function-end) (format t "~&::FUNCTION-END *Active* ")))) -(def-debug-command-alias "LL" "LIST-LOCATIONS") +(!def-debug-command-alias "LL" "LIST-LOCATIONS") ;;; Set breakpoint at the given number. -(def-debug-command "BREAKPOINT" () +(!def-debug-command "BREAKPOINT" () (let ((index (read-prompting-maybe "location number, :START, or :END: ")) (break t) (condition t) @@ -1554,20 +1537,20 @@ argument") (print-breakpoint-info (first *breakpoints*)) (format t "~&added")))) -(def-debug-command-alias "BP" "BREAKPOINT") +(!def-debug-command-alias "BP" "BREAKPOINT") ;;; List all breakpoints which are set. -(def-debug-command "LIST-BREAKPOINTS" () +(!def-debug-command "LIST-BREAKPOINTS" () (setf *breakpoints* (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) (dolist (info *breakpoints*) (print-breakpoint-info info))) -(def-debug-command-alias "LB" "LIST-BREAKPOINTS") -(def-debug-command-alias "LBP" "LIST-BREAKPOINTS") +(!def-debug-command-alias "LB" "LIST-BREAKPOINTS") +(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS") ;;; Remove breakpoint N, or remove all breakpoints if no N given. -(def-debug-command "DELETE-BREAKPOINT" () +(!def-debug-command "DELETE-BREAKPOINT" () (let* ((index (read-if-available nil)) (bp-info (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) @@ -1582,18 +1565,18 @@ argument") (setf *breakpoints* nil) (format t "all breakpoints deleted~%"))))) -(def-debug-command-alias "DBP" "DELETE-BREAKPOINT") +(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT") ;;; miscellaneous commands -(def-debug-command "DESCRIBE" () +(!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) (debug-fun (sb!di:code-location-debug-function curloc)) (function (sb!di:debug-function-function debug-fun))) (if function (describe function) (format t "can't figure out the function for this frame")))) - < + ;;;; debug loop command utilities (defun read-prompting-maybe (prompt &optional (in *standard-input*)