X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=a818d2bd7f601f7f925740da0dad94d052f00f13;hb=8a8a8922802460741d6f8f6c11d71b1f414cf3a7;hp=5105bb4024070d16f99f559c9ef3d415a4582999;hpb=6f408b4ce6a2f411618fe1bebf63ee08093a7d03;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 5105bb4..a818d2b 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -10,25 +10,52 @@ ;;;; files for more information. (in-package "SB!DEBUG") - -(file-comment - "$Header$") ;;;; variables and constants -(defvar *debug-print-level* 3 +;;; things to consider when tweaking these values: +;;; * We're afraid to just default them to NIL and NIL, in case the +;;; user inadvertently causes a hairy data structure to be printed +;;; when he inadvertently enters the debugger. +;;; * We don't want to truncate output too much. These days anyone +;;; can easily run their Lisp in a windowing system or under Emacs, +;;; so it's not the end of the world even if the worst case is a +;;; few thousand lines of output. +;;; * 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 +;;; error while parsing arguments to DESTRUCTURING-BIND: +;;; invalid number of elements in +;;; # +;;; to satisfy lambda list +;;; #: +;;; exactly 2 expected, but 5 found +;;; +;;; FIXME: These variables were deprecated in late February 2004, and +;;; can probably be removed in about a year. +(defvar *debug-print-level* 5 + #!+sb-doc + "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.) + +*PRINT-LEVEL* for the debugger") +(defvar *debug-print-length* 7 #!+sb-doc - "*PRINT-LEVEL* for the debugger") + "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.) -(defvar *debug-print-length* 5 +*PRINT-LENGTH* for the debugger") + +(defvar *debug-print-variable-alist* nil #!+sb-doc - "*PRINT-LENGTH* for the debugger") + "an association list describing new bindings for special variables +(typically *PRINT-FOO* variables) to be used within the debugger, e.g. +((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))") (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,57 +64,56 @@ #!+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) + +;;; 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-hint* nil - #!+sb-doc - "If this is bound before the debugger is invoked, it is used as the stack - top by the debugger.") (defvar *stack-top* nil) (defvar *real-stack-top* nil) (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*") - +;;; 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) + (sb!thread::get-foreground) + (format stream + "~%~W~:[~;[~W~]] " + (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*. -Debug commands do not affect * and friends, but evaluation in the debug loop - do affect these variables. +"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 + its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*. +Debug commands do not affect *, //, and similar variables, but evaluation in + the debug loop does affect these variables. SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt - drop you into deeper into the debugger. + drop you 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. + The number of any restart, or its name, or a unique abbreviation for its + name, 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. @@ -95,145 +121,32 @@ Inspecting frames: PRINT, P displays current function call. 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. - Abbreviation: LL - LIST-BREAKPOINTS List the active breakpoints. - Abbreviations: LB, LBP - DELETE-BREAKPOINT [n] Remove breakpoint n or all breakpoints. - Abbreviations: DEL, DBP - BREAKPOINT {n | :end | :start} [:break form] [:function function] - [{:print form}*] [:condition form] - Set a breakpoint. - Abbreviations: BR, BP - STEP [n] Step to the next location or step n times. +Stepping: + STEP + [EXPERIMENTAL] 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 Manul for details. Function and macro commands: - (SB-DEBUG:DEBUG-RETURN expression) - Exit the debugger, returning expression's values from the current frame. (SB-DEBUG:ARG n) Return the n'th argument in the current frame. (SB-DEBUG:VAR string-or-symbol [id]) - Returns the value of the specified variable in the current frame.") + Returns the value of the specified variable in the current frame. + +Other commands: + RETURN expr + [EXPERIMENTAL] Return the values resulting from evaluation of expr + from the current frame, if this frame was compiled with a sufficiently + high DEBUG optimization quality. + SLURP + Discard all pending input on *STANDARD-INPUT*. (This can be + useful when the debugger was invoked to handle an error in + deeply nested input syntax, and now the reader is confused.)") -;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. -(define-condition step-condition (simple-condition) ()) - -;;;; breakpoint state - -(defvar *only-block-start-locations* nil - #!+sb-doc - "When true, the LIST-LOCATIONS command only displays block start locations. - Otherwise, all locations are displayed.") -(defvar *print-location-kind* nil - #!+sb-doc - "When true, list the code location type in the LIST-LOCATIONS command.") - -;;; a list of the types of code-locations that should not be stepped to and -;;; should not be listed when listing breakpoints -(defvar *bad-code-location-types* '(:call-site :internal-error)) -(declaim (type list *bad-code-location-types*)) - -;;; code locations of the possible breakpoints -(defvar *possible-breakpoints*) -(declaim (type list *possible-breakpoints*)) - -;;; a list of the made and active breakpoints, each is a breakpoint-info -;;; structure -(defvar *breakpoints* nil) -(declaim (type list *breakpoints*)) - -;;; a list of breakpoint-info structures of the made and active step -;;; breakpoints -(defvar *step-breakpoints* nil) -(declaim (type list *step-breakpoints*)) - -;;; the number of times left to step -(defvar *number-of-steps* 1) -(declaim (type integer *number-of-steps*)) - -;;; This is used when listing and setting breakpoints. -(defvar *default-breakpoint-debug-function* nil) -(declaim (type (or list sb!di:debug-function) *default-breakpoint-debug-function*)) - -;;;; code location utilities - -;;; Return the first code-location in the passed debug block. -(defun first-code-location (debug-block) - (let ((found nil) - (first-code-location nil)) - (sb!di:do-debug-block-locations (code-location debug-block) - (unless found - (setf first-code-location code-location) - (setf found t))) - first-code-location)) - -;;; Return a list of the next code-locations following the one passed. One of -;;; the *BAD-CODE-LOCATION-TYPES* will not be returned. -(defun next-code-locations (code-location) - (let ((debug-block (sb!di:code-location-debug-block code-location)) - (block-code-locations nil)) - (sb!di:do-debug-block-locations (block-code-location debug-block) - (unless (member (sb!di:code-location-kind block-code-location) - *bad-code-location-types*) - (push block-code-location block-code-locations))) - (setf block-code-locations (nreverse block-code-locations)) - (let* ((code-loc-list (rest (member code-location block-code-locations - :test #'sb!di:code-location=))) - (next-list (cond (code-loc-list - (list (first code-loc-list))) - ((map 'list #'first-code-location - (sb!di:debug-block-successors debug-block))) - (t nil)))) - (when (and (= (length next-list) 1) - (sb!di:code-location= (first next-list) code-location)) - (setf next-list (next-code-locations (first next-list)))) - next-list))) - -;;; Returns a list of code-locations of the possible breakpoints of the -;;; debug-function passed. -(defun possible-breakpoints (debug-function) - (let ((possible-breakpoints nil)) - (sb!di:do-debug-function-blocks (debug-block debug-function) - (unless (sb!di:debug-block-elsewhere-p debug-block) - (if *only-block-start-locations* - (push (first-code-location debug-block) possible-breakpoints) - (sb!di:do-debug-block-locations (code-location debug-block) - (when (not (member (sb!di:code-location-kind code-location) - *bad-code-location-types*)) - (push code-location possible-breakpoints)))))) - (nreverse possible-breakpoints))) - -;;; Searches the info-list for the item passed (code-location, debug-function, -;;; or breakpoint-info). If the item passed is a debug function then kind will -;;; be compared if it was specified. The kind if also compared if a -;;; breakpoint-info is passed since it's in the breakpoint. The info structure -;;; is returned if found. -(defun location-in-list (place info-list &optional (kind nil)) - (when (breakpoint-info-p place) - (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place))) - (setf place (breakpoint-info-place place))) - (cond ((sb!di:code-location-p place) - (find place info-list - :key #'breakpoint-info-place - :test #'(lambda (x y) (and (sb!di:code-location-p y) - (sb!di:code-location= x y))))) - (t - (find place info-list - :test #'(lambda (x-debug-function y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-function-p y-place) - (eq x-debug-function y-place) - (or (not kind) - (eq kind (sb!di:breakpoint-kind - y-breakpoint)))))))))) - -;;; If Loc is an unknown location, then try to find the block start location. -;;; Used by source printing to some information instead of none for the user. +;;; If LOC is an unknown location, then try to find the block start +;;; location. Used by source printing to some information instead of +;;; none for the user. (defun maybe-block-start-location (loc) (if (sb!di:code-location-unknown-p loc) (let* ((block (sb!di:code-location-debug-block loc)) @@ -248,195 +161,13 @@ Function and macro commands: loc))) loc)) -;;;; the BREAKPOINT-INFO structure - -;;; info about a made breakpoint -(defstruct breakpoint-info - ;; where we are going to stop - (place (required-argument) - :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 - ;; non-NIL, drop into the debugger. - (break #'identity :type function) - ;; the function returned from sb!di:preprocess-for-eval. If result is - ;; non-NIL, eval (each) print and print results. - (condition #'identity :type function) - ;; the list of functions from sb!di:preprocess-for-eval to evaluate. Results - ;; are conditionally printed. Car of each element is the function, cdr is the - ;; form it goes with. - (print nil :type list) - ;; the number used when listing the possible breakpoints within a function. - ;; Could also be a symbol such as start or end. - (code-location-number (required-argument) :type (or symbol integer)) - ;; the number used when listing the breakpoints active and to delete - ;; breakpoints - (breakpoint-number (required-argument) :type integer)) - -;;; Return a new BREAKPOINT-INFO structure with the info passed. -(defun create-breakpoint-info (place breakpoint code-location-number - &key (break #'identity) - (condition #'identity) (print nil)) - (setf *breakpoints* - (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number)) - (let ((breakpoint-number - (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints))) - ((or (> i (length *breakpoints*)) - (not (= i (breakpoint-info-breakpoint-number - (first breakpoints))))) - - i)))) - (make-breakpoint-info :place place :breakpoint breakpoint - :code-location-number code-location-number - :breakpoint-number breakpoint-number - :break break :condition condition :print print))) - -;;; Print the breakpoint info for the breakpoint-info structure passed. -(defun print-breakpoint-info (breakpoint-info) - (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-number breakpoint-info)) - (loc-number (breakpoint-info-code-location-number breakpoint-info))) - (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) - (:code-location - (print-code-location-source-form place 0) - (format t - "~&~S: ~S in ~S" - bp-number - loc-number - (sb!di:debug-function-name (sb!di:code-location-debug-function - place)))) - (:function-start - (format t "~&~S: FUNCTION-START in ~S" bp-number - (sb!di:debug-function-name place))) - (:function-end - (format t "~&~S: FUNCTION-END in ~S" bp-number - (sb!di:debug-function-name place)))))) - -;;;; MAIN-HOOK-FUNCTION for steps and breakpoints - -;;; This must be passed as the hook function. It keeps track of where step -;;; breakpoints are. -(defun main-hook-function (current-frame breakpoint &optional return-vals - function-end-cookie) - (setf *default-breakpoint-debug-function* - (sb!di:frame-debug-function current-frame)) - (dolist (step-info *step-breakpoints*) - (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info)) - (let ((bp-info (location-in-list step-info *breakpoints*))) - (when bp-info - (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info))))) - (let ((*stack-top-hint* current-frame) - (step-hit-info - (location-in-list (sb!di:breakpoint-what breakpoint) - *step-breakpoints* - (sb!di:breakpoint-kind breakpoint))) - (bp-hit-info - (location-in-list (sb!di:breakpoint-what breakpoint) - *breakpoints* - (sb!di:breakpoint-kind breakpoint))) - (break) - (condition) - (string "")) - (setf *step-breakpoints* nil) - (labels ((build-string (str) - (setf string (concatenate 'string string str))) - (print-common-info () - (build-string - (with-output-to-string (*standard-output*) - (when function-end-cookie - (format t "~%Return values: ~S" return-vals)) - (when condition - (when (breakpoint-info-print bp-hit-info) - (format t "~%") - (print-frame-call current-frame)) - (dolist (print (breakpoint-info-print bp-hit-info)) - (format t "~& ~S = ~S" (rest print) - (funcall (first print) current-frame)))))))) - (when bp-hit-info - (setf break (funcall (breakpoint-info-break bp-hit-info) - current-frame)) - (setf condition (funcall (breakpoint-info-condition bp-hit-info) - current-frame))) - (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*)) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info break) - (build-string (format nil "~&*Step (to a breakpoint)*")) - (print-common-info) - (break string)) - ((and bp-hit-info step-hit-info) - (print-common-info) - (format t "~A" string) - (decf *number-of-steps*) - (set-step-breakpoint current-frame)) - ((and step-hit-info (= 1 *number-of-steps*)) - (build-string "*Step*") - (break (make-condition 'step-condition :format-control string))) - (step-hit-info - (decf *number-of-steps*) - (set-step-breakpoint current-frame)) - (bp-hit-info - (when break - (build-string (format nil "~&*Breakpoint hit*"))) - (print-common-info) - (if break - (break string) - (format t "~A" string))) - (t - (break "error in main-hook-function: unknown breakpoint")))))) - -;;; Set breakpoints at the next possible code-locations. After calling -;;; this, either (CONTINUE) if in the debugger or just let program flow -;;; return if in a hook function. -(defun set-step-breakpoint (frame) - (cond - ((sb!di:debug-block-elsewhere-p (sb!di:code-location-debug-block - (sb!di:frame-code-location frame))) - ;; FIXME: FORMAT T is used for error output here and elsewhere in - ;; the debug code. - (format t "cannot step, in elsewhere code~%")) - (t - (let* ((code-location (sb!di:frame-code-location frame)) - (next-code-locations (next-code-locations code-location))) - (cond - (next-code-locations - (dolist (code-location next-code-locations) - (let ((bp-info (location-in-list code-location *breakpoints*))) - (when bp-info - (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint - bp-info)))) - (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location - :kind :code-location))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info code-location bp 0) - *step-breakpoints*)))) - (t - (let* ((debug-function (sb!di:frame-debug-function *current-frame*)) - (bp (sb!di:make-breakpoint #'main-hook-function debug-function - :kind :function-end))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info debug-function bp 0) - *step-breakpoints*)))))))) - -;;;; STEP - -;;; ANSI specifies that this macro shall exist, even if only as a -;;; trivial placeholder like this. -(defmacro step (form) - "a trivial placeholder implementation of the CL:STEP macro required by - the ANSI spec" - `(progn - ,form)) - ;;;; BACKTRACE (defun backtrace (&optional (count most-positive-fixnum) (*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)) @@ -446,13 +177,27 @@ Function and macro commands: (print-frame-call frame :number t)) (fresh-line *standard-output*) (values)) + +(defun backtrace-as-list (&optional (count most-positive-fixnum)) + #!+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)) + (count count (1- count))) + ((or (null frame) (zerop count)) + (nreverse reversed-result)) + (push (frame-call-as-list frame) reversed-result))) + +(defun frame-call-as-list (frame) + (cons (sb!di:debug-fun-name (sb!di:frame-debug-fun frame)) + (frame-args-as-list frame))) ;;;; frame printing (eval-when (:compile-toplevel :execute) -;;; This is a convenient way to express what to do for each type of lambda-list -;;; element. +;;; 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 @@ -469,7 +214,7 @@ Function and macro commands: (:rest ,@rest) (:keyword ,@keyword))) (symbol - (assert (eq ,element :deleted)) + (aver (eq ,element :deleted)) ,@deleted))) (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other) @@ -483,49 +228,73 @@ Function and macro commands: ) ; 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. +;;; 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 :type t) + (print-unreadable-object (x s) (write-string (unprintable-object-string x) - s))))) + s)))) + (:copier nil)) string) -;;; 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. -(defun print-frame-call-1 (frame) - (let* ((d-fun (sb!di:frame-debug-function frame)) - (loc (sb!di:frame-code-location frame)) - (results (list (sb!di:debug-function-name d-fun)))) +;;; 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)) (handler-case - (dolist (ele (sb!di:debug-function-lambda-list d-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) results)) - :optional ((push (frame-call-arg (second ele) loc frame) results)) - :keyword ((push (second ele) results) - (push (frame-call-arg (third ele) loc frame) results)) - :deleted ((push (frame-call-arg ele loc frame) results)) - :rest ((lambda-var-dispatch (second ele) loc + (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 results + (setf reversed-result (append (reverse (sb!di:debug-var-value (second ele) frame)) - results)) + reversed-result)) (return)) - (push (make-unprintable-object "unavailable &REST arg") - results))))) + (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 () - (push (make-unprintable-object "lambda list unavailable") results))) - (prin1 (mapcar #'ensure-printable-object (nreverse results))) - (when (sb!di:debug-function-kind d-fun) + (make-unprintable-object "unavailable lambda list"))))) + +;;; 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. +(defun print-frame-call-1 (frame) + (let ((debug-fun (sb!di:frame-debug-fun frame))) + + (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") + (let ((args (ensure-printable-object (frame-args-as-list frame)))) + ;; Since we go to some trouble to make nice informative function + ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure + ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*. + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun)))) + ;; For the function arguments, we can just print normally. + (if (listp args) + (format t "~{ ~_~S~}" args) + (format t " ~S" args)))) + + (when (sb!di:debug-fun-kind debug-fun) (write-char #\[) - (prin1 (sb!di:debug-function-kind d-fun)) + (prin1 (sb!di:debug-fun-kind debug-fun)) (write-char #\])))) (defun ensure-printable-object (object) @@ -539,13 +308,13 @@ 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; -;;; zero indicates just printing the debug-function's name, and one +;;; 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-FUN's name, and one ;;; indicates displaying call-like, one-liner format with argument ;;; values. (defun print-frame-call (frame &key (verbosity 1) (number nil)) @@ -578,98 +347,325 @@ Function and macro commands: of this variable to the function because it binds *DEBUGGER-HOOK* to NIL around the invocation.") +(defvar *invoke-debugger-hook* nil + #!+sb-doc + "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* + + 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 + called by BREAK.") + ;;; These are bound on each invocation of INVOKE-DEBUGGER. (defvar *debug-restarts*) (defvar *debug-condition*) - +(defvar *nested-debug-condition*) + +;;; Oh, what a tangled web we weave when we preserve backwards +;;; compatibility with 1968-style use of global variables to control +;;; per-stream i/o properties; there's really no way to get this +;;; quite right, but we do what we can. +(defun funcall-with-debug-io-syntax (fun &rest rest) + (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*)) + (with-standard-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 did much of what we + ;; want, but + ;; * It doesn't affect our internal special variables + ;; like *CURRENT-LEVEL-IN-PRINT*. + ;; * It isn't customizable. + ;; * It doesn't set *PRINT-READABLY* to the same value + ;; as the toplevel default. + ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not + ;; helpful behavior for a debugger. + ;; * There's no particularly good debugger default for + ;; *PRINT-PRETTY*, since T is usually what you want + ;; -- except absolutely not what you want when you're + ;; debugging failures in PRINT-OBJECT logic. + ;; We try to address all these issues with explicit + ;; rebindings here. + (sb!kernel:*current-level-in-print* 0) + (*package* original-package) + (*print-pretty* original-print-pretty) + (*print-readably* nil) + ;; Clear the circularity machinery to try to to reduce the + ;; pain from sharing the circularity table across all + ;; streams; if these are not rebound here, then setting + ;; *PRINT-CIRCLE* within the debugger when debugging in a + ;; state where something circular was being printed (e.g., + ;; because the debugger was entered on an error in a + ;; PRINT-OBJECT method) makes a hopeless mess. Binding them + ;; here does seem somewhat ugly because it makes it more + ;; difficult to debug the printing-of-circularities code + ;; itself; however, as far as I (WHN, 2004-05-29) can see, + ;; that's almost entirely academic as long as there's one + ;; shared *C-H-T* for all streams (i.e., it's already + ;; unreasonably difficult to debug print-circle machinery + ;; given the buggy crosstalk between the debugger streams + ;; and the stream you're trying to watch), and any fix for + ;; that buggy arrangement will likely let this hack go away + ;; naturally. + (sb!impl::*circularity-hash-table* . nil) + (sb!impl::*circularity-counter* . nil) + ;; These rebindings are now (as of early 2004) deprecated, + ;; with the new *PRINT-VAR-ALIST* mechanism preferred. + (*print-length* *debug-print-length*) + (*print-level* *debug-print-level*) + (*readtable* *debug-readtable*)) + (progv + ;; (Why NREVERSE? PROGV makes the later entries have + ;; precedence over the earlier entries. + ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's + ;; expected that its earlier entries have precedence. And + ;; the earlier-has-precedence behavior is mostly more + ;; convenient, so that programmers can use PUSH or LIST* to + ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.) + (nreverse (mapcar #'car *debug-print-variable-alist*)) + (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 hook condition hook)))) - (sb!unix:unix-sigsetmask 0) - (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX - (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*. - ;; 2. It isn't customizable. - ;; 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. - (sb!kernel:*current-level* 0) - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) - (*readtable* *debug-readtable*) - (*print-readably* nil) - (*print-pretty* t) - (*package* original-package)) - (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.. - (*error-output* *debug-io*)) - (unless (typep condition 'step-condition) - (show-restarts *debug-restarts* *error-output*)) - (internal-debug)))))) - -(defun show-restarts (restarts &optional (s *error-output*)) - (when restarts - (format s "~&restarts:~%") - (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))) - (cond ((member name names-used) - (format s "~& ~2D: ~@VT~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))))) - -;;; 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. + (funcall old-hook condition old-hook)))) + (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 + + ;; We definitely want *PACKAGE* to be of valid type. + ;; + ;; Elsewhere in the system, we use the SANE-PACKAGE function for + ;; this, but here causing an exception just as we're trying to handle + ;; an exception would be confusing, so instead we use a special hack. + (unless (and (packagep *package*) + (package-name *package*)) + (setf *package* (find-package :cl-user)) + (format *error-output* + "The value of ~S was not an undeleted PACKAGE. It has been +reset to ~S." + '*package* *package*)) + + ;; Before we start our own output, finish any pending output. + ;; Otherwise, if the user tried to track the progress of his program + ;; using PRINT statements, he'd tend to lose the last line of output + ;; or so, which'd be confusing. + (flush-standard-output-streams) + + (funcall-with-debug-io-syntax #'%invoke-debugger condition)) + +(defun %invoke-debugger (condition) + + (let ((*debug-condition* condition) + (*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*) + (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 ~ + 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*))))) + + (let ((background-p (sb!thread::debugger-wait-until-foreground-thread + *debug-io*))) + + ;; 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) + + (unwind-protect + (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems 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*. (CMU CL + ;; used to rebind *STANDARD-INPUT* here too, but that's + ;; been fixed already.) + (*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) + (when *debug-beginner-help-p* + (format *debug-io* + "~%~@~2%")) + (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" +;;; command-line option +(defun debugger-disabled-hook (condition me) + (declare (ignore me)) + ;; There is no one there to interact with, so report the + ;; condition and terminate the program. + (flet ((failure-quit (&key recklessly-p) + (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") + (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 + ;; 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: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)) + (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 :recklessly-p t))))) + +;;; 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))) + +(defun enable-debugger () + (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *invoke-debugger-hook* nil))) + +(setf *debug-io* *query-io*) + +(defun show-restarts (restarts s) + (cond ((null restarts) + (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 ~ + 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))) + (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") + +;;; 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.~%")) - #!-mp (debug-loop) - #!+mp (sb!mp:without-scheduling (debug-loop)))) + (clear-input *debug-io*)) + (funcall *debug-loop-fun*))) ;;;; DEBUG-LOOP @@ -680,78 +676,62 @@ Function and macro commands: "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") -(defun debug-loop () +(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*)) - (handler-bind ((sb!di:debug-condition (lambda (condition) - (princ condition *debug-io*) - (throw 'debug-loop-catcher nil)))) + (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)))) (fresh-line) (print-frame-call *current-frame* :verbosity 2) (loop (catch 'debug-loop-catcher - (handler-bind ((error #'(lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t - "~&error flushed (because ~ - ~S is set)" - '*flush-debug-errors*) - (throw 'debug-loop-catcher nil))))) - ;; We have to bind level for the restart function created by + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + ;; FIXME: Doing input on *DEBUG-IO* + ;; and output on T seems broken. + (format t + "~&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 "Return to debug level ~D." level) - (funcall *debug-prompt*) - (let ((input (sb!int:get-stream-command *debug-io*))) - (cond (input - (let ((cmd-fun (debug-command-p - (sb!int:stream-command-name input) - restart-commands))) - (cond - ((not cmd-fun) - (error "unknown stream-command: ~S" input)) - ((consp cmd-fun) - (error "ambiguous debugger command: ~S" cmd-fun)) - (t - (apply cmd-fun - (sb!int:stream-command-args input)))))) + (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 t "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format t " ~A~%" ele))) (t - (let* ((exp (read)) - (cmd-fun (debug-command-p exp - restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format t - "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format t " ~A~%" ele))) - (t - (funcall cmd-fun))))))))))))))) - -(defvar *auto-eval-in-frame* t - #!+sb-doc - "When set (the default), 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.") + (funcall cmd-fun)))))))))))) ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. -(defun debug-eval-print (exp) - (setq +++ ++ ++ + + - - exp) - (let* ((values (multiple-value-list - (if (and (fboundp 'compile) *auto-eval-in-frame*) - (sb!di:eval-in-frame *current-frame* -) - (eval -)))) +(defun debug-eval-print (expr) + (/noshow "entering DEBUG-EVAL-PRINT" expr) + (/noshow (fboundp 'compile)) + (setq +++ ++ ++ + + - - expr) + (let* ((values (multiple-value-list (eval -))) (*standard-output* *debug-io*)) + (/noshow "done with EVAL in DEBUG-EVAL-PRINT") (fresh-line) (if values (prin1 (car values))) (dolist (x (cdr values)) @@ -763,31 +743,29 @@ 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 -;;; These commands are functions, not really commands, so that users can get -;;; their hands on the values returned. +;;; These commands are functions, not really commands, so that users +;;; can get their hands on the values returned. (eval-when (:execute :compile-toplevel) (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name - (symbol (sb!di:debug-function-symbol-variables - (sb!di:frame-debug-function *current-frame*) + (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-function *current-frame*) + (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)) + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) temp))) (declare (list vars)) (cond ((null vars) @@ -800,8 +778,8 @@ Function and macro commands: `(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. + ;; 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))) @@ -823,26 +801,27 @@ 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) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) + (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. + ;; 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, ~D: should have been one of ~S" + "invalid variable ID, ~W: should have been one of ~S" id (mapcar #'sb!di:debug-var-id vars))) ,(ecase ref-or-set @@ -858,9 +837,11 @@ Function and macro commands: ) ; EVAL-WHEN +;;; FIXME: This doesn't work. It would be real nice we could make it +;;; work! Alas, it doesn't seem to work in CMU CL X86 either.. (defun var (name &optional (id 0 id-supplied)) #!+sb-doc - "Returns a variable's value if possible. Name is a simple-string or symbol. + "Return a variable's value if possible. NAME is a simple-string or symbol. If it is a simple-string, it is an initial substring of the variable's name. If name is a symbol, it has the same name and package as the variable whose value this function returns. If the symbol is uninterned, then the variable @@ -879,11 +860,15 @@ 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-FUN-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. +;;; +;;; FIXME: There's probably some way to merge the code here with +;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared +;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.) (declaim (ftype (function (index list)) nth-arg)) (defun nth-arg (count args) (let ((n count)) @@ -900,7 +885,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,17 +894,17 @@ 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) #!+sb-doc - "Returns the N'th argument's value if possible. Argument zero is the first + "Return the N'th argument's value if possible. Argument zero is the first argument in a frame's default printed representation. Count keyword/value pairs as separate arguments." (multiple-value-bind (var lambda-var-p) - (nth-arg n (handler-case (sb!di:debug-function-lambda-list - (sb!di:frame-debug-function *current-frame*)) + (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.")))) (if lambda-var-p @@ -935,10 +920,8 @@ Function and macro commands: ;;; 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=)) @@ -949,24 +932,25 @@ Function and macro commands: (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*)) new-name) -;;; This takes a symbol and uses its name to find a debugger command, using -;;; initial substring matching. It returns the command function if form -;;; identifies only one command, but if form is ambiguous, this returns a list -;;; of the command names. If there are no matches, this returns nil. Whenever -;;; the loop that looks for a set of possibilities encounters an exact name -;;; match, we return that command function immediately. +;;; This takes a symbol and uses its name to find a debugger command, +;;; using initial substring matching. It returns the command function +;;; if form identifies only one command, but if form is ambiguous, +;;; this returns a list of the command names. If there are no matches, +;;; this returns nil. Whenever the loop that looks for a set of +;;; possibilities encounters an exact name match, we return that +;;; command function immediately. (defun debug-command-p (form &optional other-commands) (if (or (symbolp form) (integerp form)) (let* ((name (if (symbolp form) (symbol-name form) - (format nil "~D" form))) + (format nil "~W" form))) (len (length name)) (res nil)) (declare (simple-string name) @@ -997,29 +981,31 @@ Function and macro commands: ((not cmds) res) (setf (car cmds) (caar cmds)))))))) -;;; Returns a list of debug commands (in the same format as *debug-commands*) -;;; that invoke each active restart. +;;; Return a list of debug commands (in the same format as +;;; *DEBUG-COMMANDS*) that invoke each active restart. ;;; -;;; Two commands are made for each restart: one for the number, and one for -;;; the restart name (unless it's been shadowed by an earlier restart of the -;;; same name). +;;; Two commands are made for each restart: one for the number, and +;;; one for the restart name (unless it's been shadowed by an earlier +;;; 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! (dolist (restart restarts) (let ((name (string (restart-name restart)))) - (unless (find name commands :key #'car :test #'string=) - (let ((restart-fun - #'(lambda () - (invoke-restart-interactively restart)))) - (push (cons name restart-fun) commands) - (push (cons (format nil "~D" num) restart-fun) commands)))) - (incf num)) - commands)) + (let ((restart-fun + (lambda () + (/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)) + (find name commands :key #'car :test #'string=)) + (push (cons name restart-fun) commands)))) + (incf num)) + commands)) ;;;; 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) @@ -1027,7 +1013,7 @@ Function and macro commands: (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) @@ -1035,26 +1021,29 @@ Function and macro commands: (t (format t "~&Bottom of stack."))))) -(def-debug-command-alias "D" "DOWN") +(!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" () +(!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*)) @@ -1073,35 +1062,46 @@ Function and macro commands: (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 -(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.")) - -(def-debug-command "RESTART" () +;;; 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::toplevel-catcher nil)) + +;;; CMU CL supported this GO debug command, but SBCL doesn't -- in +;;; SBCL you just type the CONTINUE restart name instead (or "C" 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" () + (/show0 "doing RESTART debug-command") (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*))) + (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))))) + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) (t (format t "~S is invalid as a restart name.~%" num) (return-from restart-debug-command nil))))) + (/show0 "got RESTART") (if restart (invoke-restart-interactively restart) ;; FIXME: Even if this isn't handled by WARN, it probably @@ -1112,33 +1112,33 @@ Function and macro commands: ;;;; 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" () - (format t "~A~%" *debug-condition*) - (show-restarts *debug-restarts*)) +(!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" () - (let ((d-fun (sb!di:frame-debug-function *current-frame*))) +(!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*)) @@ -1151,7 +1151,7 @@ Function and macro commands: (setf any-p t) (when (eq (sb!di:debug-var-validity v location) :valid) (setf any-valid-p t) - (format t "~S~:[#~D~;~*~] = ~S~%" + (format t "~S~:[#~W~;~*~] = ~S~%" (sb!di:debug-var-symbol v) (zerop (sb!di:debug-var-id v)) (sb!di:debug-var-id v) @@ -1168,17 +1168,18 @@ Function and macro commands: 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))) ;;;; 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 @@ -1196,43 +1197,45 @@ Function and macro commands: (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*) - -;;; 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*) +;;; Stuff to clean up before saving a core +(defun debug-deinit () + (setf *cached-debug-source* nil + *cached-source-stream* nil + *cached-readtable* nil)) + +;;; We also cache the last toplevel form that we printed a source for +;;; so that we don't have to do repeated reads and calls to +;;; FORM-NUMBER-TRANSLATIONS. +(defvar *cached-toplevel-form-offset* nil) +(declaim (type (or index null) *cached-toplevel-form-offset*)) +(defvar *cached-toplevel-form*) (defvar *cached-form-number-translations*) -;;; Given a code location, return the associated form-number translations and -;;; the actual top-level form. We check our cache --- if there is a miss, we -;;; dispatch on the kind of the debug source. -(defun get-top-level-form (location) +;;; Given a code location, return the associated form-number +;;; translations and the actual top level form. We check our cache --- +;;; if there is a miss, we dispatch on the kind of the debug source. +(defun get-toplevel-form (location) (let ((d-source (sb!di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) - (eql (sb!di:code-location-top-level-form-offset location) - *cached-top-level-form-offset*)) - (values *cached-form-number-translations* *cached-top-level-form*) - (let* ((offset (sb!di:code-location-top-level-form-offset location)) + (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-top-level-form location)) + (:file (get-file-toplevel-form location)) (:lisp (svref (sb!di:debug-source-name d-source) offset))))) - (setq *cached-top-level-form-offset* offset) + (setq *cached-toplevel-form-offset* offset) (values (setq *cached-form-number-translations* (sb!di:form-number-translations res offset)) - (setq *cached-top-level-form* res)))))) + (setq *cached-toplevel-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. -(defun get-file-top-level-form (location) +;;; 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-top-level-form-offset 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 @@ -1271,10 +1274,10 @@ Function and macro commands: (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))) + (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) *cached-readtable*)) (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) @@ -1282,237 +1285,63 @@ Function and macro commands: (defun print-code-location-source-form (location context) (let* ((location (maybe-block-start-location location)) (form-num (sb!di:code-location-form-number location))) - (multiple-value-bind (translations form) (get-top-level-form location) + (multiple-value-bind (translations form) (get-toplevel-form location) (unless (< form-num (length translations)) (error "The source path no longer exists.")) (prin1 (sb!di:source-path-context form (svref translations form-num) context))))) -;;; breakpoint and step commands - -;;; Step to the next code-location. -(def-debug-command "STEP" () - (setf *number-of-steps* (read-if-available 1)) - (set-step-breakpoint *current-frame*) - (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. -(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))) - (setf *default-breakpoint-debug-function* df)) - ((or (eq ':c df) - (not *default-breakpoint-debug-function*)) - (setf df (sb!di:frame-debug-function *current-frame*)) - (setf *default-breakpoint-debug-function* df))) - (setf *possible-breakpoints* (possible-breakpoints df))) - (let ((continue-at (sb!di:frame-code-location *current-frame*))) - (let ((active (location-in-list *default-breakpoint-debug-function* - *breakpoints* :function-start)) - (here (sb!di:code-location= - (sb!di:debug-function-start-location - *default-breakpoint-debug-function*) continue-at))) - (when (or active here) - (format t "::FUNCTION-START ") - (when active (format t " *Active*")) - (when here (format t " *Continue here*")))) - - (let ((prev-location nil) - (prev-num 0) - (this-num 0)) - (flet ((flush () - (when prev-location - (let ((this-num (1- this-num))) - (if (= prev-num this-num) - (format t "~&~D: " prev-num) - (format t "~&~D-~D: " prev-num this-num))) - (print-code-location-source-form prev-location 0) - (when *print-location-kind* - (format t "~S " (sb!di:code-location-kind prev-location))) - (when (location-in-list prev-location *breakpoints*) - (format t " *Active*")) - (when (sb!di:code-location= prev-location continue-at) - (format t " *Continue here*"))))) - - (dolist (code-location *possible-breakpoints*) - (when (or *print-location-kind* - (location-in-list code-location *breakpoints*) - (sb!di:code-location= code-location continue-at) - (not prev-location) - (not (eq (sb!di:code-location-debug-source code-location) - (sb!di:code-location-debug-source prev-location))) - (not (eq (sb!di:code-location-top-level-form-offset - code-location) - (sb!di:code-location-top-level-form-offset - prev-location))) - (not (eq (sb!di:code-location-form-number code-location) - (sb!di:code-location-form-number prev-location)))) - (flush) - (setq prev-location code-location prev-num this-num)) - - (incf this-num)))) - - (when (location-in-list *default-breakpoint-debug-function* - *breakpoints* - :function-end) - (format t "~&::FUNCTION-END *Active* ")))) - -(def-debug-command-alias "LL" "LIST-LOCATIONS") - -;;; Set breakpoint at the given number. -(def-debug-command "BREAKPOINT" () - (let ((index (read-prompting-maybe "location number, :START, or :END: ")) - (break t) - (condition t) - (print nil) - (print-functions nil) - (function nil) - (bp) - (place *default-breakpoint-debug-function*)) - (flet ((get-command-line () - (let ((command-line nil) - (unique '(nil))) - (loop - (let ((next-input (read-if-available unique))) - (when (eq next-input unique) (return)) - (push next-input command-line))) - (nreverse command-line))) - (set-vars-from-command-line (command-line) - (do ((arg (pop command-line) (pop command-line))) - ((not arg)) - (ecase arg - (:condition (setf condition (pop command-line))) - (:print (push (pop command-line) print)) - (:break (setf break (pop command-line))) - (:function - (setf function (eval (pop command-line))) - (setf *default-breakpoint-debug-function* - (sb!di:function-debug-function function)) - (setf place *default-breakpoint-debug-function*) - (setf *possible-breakpoints* - (possible-breakpoints - *default-breakpoint-debug-function*)))))) - (setup-function-start () - (let ((code-loc (sb!di:debug-function-start-location place))) - (setf bp (sb!di:make-breakpoint #'main-hook-function - place - :kind :function-start)) - (setf break (sb!di:preprocess-for-eval break code-loc)) - (setf condition (sb!di:preprocess-for-eval condition code-loc)) - (dolist (form print) - (push (cons (sb!di:preprocess-for-eval form code-loc) form) - print-functions)))) - (setup-function-end () - (setf bp - (sb!di:make-breakpoint #'main-hook-function - place - :kind :function-end)) - (setf break - ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..) - ;; forms should be converted to shiny new (LAMBDA ..) forms. - ;; (Search the sources for "coerce.*\(lambda".) - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,break) - 'function)) - (setf condition (coerce `(lambda (dummy) - (declare (ignore dummy)) ,condition) - 'function)) - (dolist (form print) - (push (cons - (coerce `(lambda (dummy) - (declare (ignore dummy)) ,form) 'function) - form) - print-functions))) - (setup-code-location () - (setf place (nth index *possible-breakpoints*)) - (setf bp (sb!di:make-breakpoint #'main-hook-function - place - :kind :code-location)) - (dolist (form print) - (push (cons - (sb!di:preprocess-for-eval form place) - form) - print-functions)) - (setf break (sb!di:preprocess-for-eval break place)) - (setf condition (sb!di:preprocess-for-eval condition place)))) - (set-vars-from-command-line (get-command-line)) - (cond - ((or (eq index :start) (eq index :s)) - (setup-function-start)) - ((or (eq index :end) (eq index :e)) - (setup-function-end)) - (t - (setup-code-location))) - (sb!di:activate-breakpoint bp) - (let* ((new-bp-info (create-breakpoint-info place bp index - :break break - :print print-functions - :condition condition)) - (old-bp-info (location-in-list new-bp-info *breakpoints*))) - (when old-bp-info - (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint - old-bp-info)) - (setf *breakpoints* (remove old-bp-info *breakpoints*)) - (format t "previous breakpoint removed~%")) - (push new-bp-info *breakpoints*)) - (print-breakpoint-info (first *breakpoints*)) - (format t "~&added")))) - -(def-debug-command-alias "BP" "BREAKPOINT") - -;;; List all breakpoints which are set. -(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") - -;;; Remove breakpoint N, or remove all breakpoints if no N given. -(def-debug-command "DELETE-BREAKPOINT" () - (let* ((index (read-if-available nil)) - (bp-info - (find index *breakpoints* :key #'breakpoint-info-breakpoint-number))) - (cond (bp-info - (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info)) - (setf *breakpoints* (remove bp-info *breakpoints*)) - (format t "breakpoint ~S removed~%" index)) - (index (format t "The breakpoint doesn't exist.")) +;;; 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 - (dolist (ele *breakpoints*) - (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele))) - (setf *breakpoints* nil) - (format t "all breakpoints deleted~%"))))) + (format *debug-io* "~&Non-continuable error, cannot step.~%"))))) -(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))) + (debug-fun (sb!di:code-location-debug-fun curloc)) + (function (sb!di:debug-fun-fun debug-fun))) (if function (describe function) (format t "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: "))) + (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*)))) + (if tag + (throw (car tag) + (funcall (sb!di:preprocess-for-eval + return + (sb!di:frame-code-location *current-frame*)) + *current-frame*)) + (format t "~@")))) ;;;; debug loop command utilities -(defun read-prompting-maybe (prompt &optional (in *standard-input*) - (out *standard-output*)) - (unless (sb!int:listen-skip-whitespace in) - (princ prompt out) - (force-output out)) - (read in)) +(defun read-prompting-maybe (prompt) + (unless (sb!int:listen-skip-whitespace *debug-io*) + (princ prompt) + (force-output)) + (read *debug-io*)) -(defun read-if-available (default &optional (stream *standard-input*)) - (if (sb!int:listen-skip-whitespace stream) - (read stream) +(defun read-if-available (default) + (if (sb!int:listen-skip-whitespace *debug-io*) + (read *debug-io*) default))