X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=90721664179a92e67c7c723f7ee02ffeda36b2af;hb=bea5b384106a6734a4b280a76e8ebdd4d51b5323;hp=b3876e87cca2b372b8f155bf64b150dc5db41135;hpb=bc59d68844ec48359a26476e5947b38a778813b6;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index b3876e8..9072166 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -31,12 +31,20 @@ ;;; to satisfy lambda list ;;; #: ;;; exactly 2 expected, but 5 found -(defvar *debug-print-level* 5 +(defvar *debug-print-variable-alist* nil #!+sb-doc - "*PRINT-LEVEL* for the debugger") -(defvar *debug-print-length* 7 - #!+sb-doc - "*PRINT-LENGTH* for the debugger") + "an association list describing new bindings for special variables +to be used within the debugger. Eg. + + ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL)) + +The variables in the CAR positions are bound to the values in the CDR +during the execution of some debug commands. When evaluating arbitrary +expressions in the debugger, the normal values of the printer control +variables are in effect. + +Initially empty, *DEBUG-PRINT-VARIABLE-ALIST* is typically used to +provide bindings for printer control variables.") (defvar *debug-readtable* ;; KLUDGE: This can't be initialized in a cold toplevel form, @@ -85,11 +93,12 @@ 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*. + its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*. Debug commands do not affect *, //, and similar variables, but evaluation in the debug loop does affect these variables. SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt - drop you deeper into the debugger. + drop you deeper into the debugger. The default NIL allows recursive entry + to debugger. Getting in and out of the debugger: RESTART invokes restart numbered as shown (prompt if not given). @@ -99,28 +108,19 @@ Getting in and out of the debugger: that restart. Changing frames: - U up frame D down frame - B bottom frame F n frame n (n=0 for top frame) + UP up frame DOWN down frame + BOTTOM bottom frame FRAME n frame n (n=0 for top frame) Inspecting frames: BACKTRACE [n] shows n frames going down the stack. - LIST-LOCALS, L lists locals in current function. - PRINT, P displays current function call. + LIST-LOCALS, L lists locals in current frame. + PRINT, P displays function call for current frame. 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 Selects the CONTINUE restart if one exists and starts + single-stepping. Single stepping affects only code compiled with + under high DEBUG optimization quality. See User Manual for details. Function and macro commands: (SB-DEBUG:ARG n) @@ -130,127 +130,15 @@ Function and macro commands: 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. + 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-fun* nil) -(declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*)) - -;;;; 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))) - -;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN. -(defun possible-breakpoints (debug-fun) - (let ((possible-breakpoints nil)) - (sb!di:do-debug-fun-blocks (debug-block debug-fun) - (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))) - -;;; Search the info-list for the item passed (CODE-LOCATION, -;;; DEBUG-FUN, 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-fun y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-fun-p y-place) - (eq x-debug-fun 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 @@ -262,212 +150,26 @@ Other commands: (return loc)))) (cond ((and (not (sb!di:debug-block-elsewhere-p block)) start) - ;; FIXME: Why output on T instead of *DEBUG-FOO* or something? - (format t "~%unknown location: using block start~%") + (format *debug-io* "~%unknown location: using block start~%") start) (t loc))) loc)) -;;;; the BREAKPOINT-INFO structure - -;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil) - (:constructor %make-breakpoint-info)) - ;; where we are going to stop - (place (missing-arg) - :type (or sb!di:code-location sb!di:debug-fun) - :read-only t) - ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT - (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t) - ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is - ;; non-NIL, drop into the debugger. - (break #'identity :type function :read-only t) - ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is - ;; non-NIL, eval (each) print and print results. - (condition #'identity :type function :read-only t) - ;; 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 :read-only t) - ;; the number used when listing the possible breakpoints within a - ;; function; or could also be a symbol such as START or END - (code-location-selector (missing-arg) :type (or symbol integer) :read-only t) - ;; the number used when listing the active breakpoints, and when - ;; deleting breakpoints - (breakpoint-number (missing-arg) :type integer :read-only t)) - -(defun create-breakpoint-info (place breakpoint code-location-selector - &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-selector code-location-selector - :breakpoint-number breakpoint-number - :break break - :condition condition - :print print))) - -(defun print-breakpoint-info (breakpoint-info) - (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-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 - (breakpoint-info-code-location-selector breakpoint-info) - (sb!di:debug-fun-name (sb!di:code-location-debug-fun place)))) - (:fun-start - (format t "~&~S: FUN-START in ~S" bp-number - (sb!di:debug-fun-name place))) - (:fun-end - (format t "~&~S: FUN-END in ~S" bp-number - (sb!di:debug-fun-name place)))))) - -;;;; MAIN-HOOK-FUN for steps and breakpoints - -;;; This must be passed as the hook function. It keeps track of where -;;; STEP breakpoints are. -(defun main-hook-fun (current-frame breakpoint &optional return-vals - fun-end-cookie) - (setf *default-breakpoint-debug-fun* - (sb!di:frame-debug-fun 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 fun-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 "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-fun code-location - :kind :code-location))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info code-location bp 0) - *step-breakpoints*)))) - (t - (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*)) - (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun - :kind :fun-end))) - (sb!di:activate-breakpoint bp) - (push (create-breakpoint-info debug-fun bp 0) - *step-breakpoints*)))))))) - -;;;; STEP - -;;; ANSI specifies that this macro shall exist, even if only as a -;;; trivial placeholder like this. -(defmacro step (form) - "This is a trivial placeholder implementation of the CL:STEP macro required - by the ANSI spec, simply expanding to `(LET () ,FORM). A more featureful - version would be welcome, we just haven't written it." - `(let () - ,form)) - ;;;; BACKTRACE -(defun backtrace (&optional (count most-positive-fixnum) - (*standard-output* *debug-io*)) +(defun backtrace (&optional (count most-positive-fixnum) (stream *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 - frames to show." - (fresh-line *standard-output*) + "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 frames to show." + (fresh-line stream) (do ((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))) - (print-frame-call frame :number t)) - (fresh-line *standard-output*) + (print-frame-call frame stream :number t)) + (fresh-line stream) (values)) (defun backtrace-as-list (&optional (count most-positive-fixnum)) @@ -481,8 +183,8 @@ Other commands: (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))) + (multiple-value-bind (name args) (frame-call frame) + (cons name args))) ;;;; frame printing @@ -563,31 +265,45 @@ Other commands: (sb!di:lambda-list-unavailable () (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-fun-kind debug-fun)) - (write-char #\])))) +(legal-fun-name-p '(lambda ())) +(defvar *show-entry-point-details* nil) + +(defun frame-call (frame) + (labels ((clean-name-and-args (name args) + (if (and (consp name) (not *show-entry-point-details*)) + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-name-and-args + (second name) + (let ((count (first args)) + (real-args (rest args))) + (subseq real-args 0 (min count (length real-args)))))) + ((sb!c::&more-processor) + (clean-name-and-args + (second name) + (let* ((more (last args 2)) + (context (first more)) + (count (second more))) + (append (butlast args 2) + (multiple-value-list + (sb!c:%more-arg-values context 0 count)))))) + ;; FIXME: do we need to deal with + ;; HAIRY-FUNCTION-ENTRY here? I can't make it or + ;; &AUX-BINDINGS appear in backtraces, so they are + ;; left alone for now. --NS 2005-02-28 + ((sb!c::hairy-arg-processor + sb!c::varargs-entry sb!c::&optional-processor) + (clean-name-and-args (second name) args)) + (t + (values name args))) + (values name args)))) + (let ((debug-fun (sb!di:frame-debug-fun frame))) + (multiple-value-bind (name args) + (clean-name-and-args (sb!di:debug-fun-name debug-fun) + (frame-args-as-list frame)) + (values name args + (when *show-entry-point-details* + (sb!di:debug-fun-kind debug-fun))))))) (defun ensure-printable-object (object) (handler-case @@ -609,25 +325,43 @@ Other commands: ;;; 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)) - (cond - ((zerop verbosity) - (when number - (format t "~&~S: " (sb!di:frame-number frame))) - (format t "~S" frame)) - (t - (when number - (format t "~&~S: " (sb!di:frame-number frame))) - (print-frame-call-1 frame))) +(defun print-frame-call (frame stream &key (verbosity 1) (number nil)) + (when number + (format stream "~&~S: " (sb!di:frame-number frame))) + (if (zerop verbosity) + (let ((*print-readably* nil)) + (prin1 frame stream)) + (multiple-value-bind (name args kind) (frame-call frame) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + ;; 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*. + ;; For the function arguments, we can just print normally. + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (ensure-printable-object name) stream)) + ;; 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. + (let ((args (ensure-printable-object args))) + (if (listp args) + (format stream "~{ ~_~S~}" args) + (format stream " ~S" args)))) + (when kind + (format stream "[~S]" kind)))) (when (>= verbosity 2) (let ((loc (sb!di:frame-code-location frame))) (handler-case (progn + ;; FIXME: Is this call really necessary here? If it is, + ;; then the reason for it should be unobscured. (sb!di:code-location-debug-block loc) - (format t "~%source: ") - (print-code-location-source-form loc 0)) - (sb!di:debug-condition (ignore) ignore) - (error (c) (format t "error finding source: ~A" c)))))) + (format stream "~%source: ") + (prin1 (code-location-source-form loc 0) stream)) + (sb!di:debug-condition (ignore) + ignore) + (error (c) + (format stream "error finding source: ~A" c)))))) ;;;; INVOKE-DEBUGGER @@ -639,30 +373,109 @@ Other 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 + (with-sane-io-syntax + (let (;; We want the printer and reader to be in a useful + ;; state, regardless of where the debugger was invoked + ;; in the program. WITH-STANDARD-IO-SYNTAX and + ;; WITH-SANE-IO-SYNTAX do much of what we want, but + ;; * It doesn't affect our internal special variables + ;; like *CURRENT-LEVEL-IN-PRINT*. + ;; * It isn't customizable. + ;; * 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) + ;; 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) + (*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/enabled (condition) +(defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." + (let ((old-hook *debugger-hook*)) (when old-hook (let ((*debugger-hook* nil)) (funcall old-hook condition old-hook)))) + (let ((old-hook *invoke-debugger-hook*)) + (when old-hook + (let ((*invoke-debugger-hook* nil)) + (funcall old-hook condition old-hook)))) - ;; If we're a background thread and *background-threads-wait-for-debugger* - ;; is NIL, this will invoke a restart - - ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it - ;; around sbcl-0.7.8.5 (by which time it had mutated to have a - ;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed - ;; on SunOS and no one knew why it was needed anywhere else either). - ;; So if something mysteriously breaks that has worked since the CMU - ;; CL days, that might be why. -- WHN 2002-09-28 + ;; 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. ;; @@ -677,120 +490,88 @@ Other commands: reset to ~S." '*package* *package*)) - ;; 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 ((*debug-condition* condition) - (*debug-restarts* (compute-restarts condition)) - (*nested-debug-condition* nil) - ;; 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) - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) - (*readtable* *debug-readtable*) - (*print-readably* nil) - (*package* original-package) - (background-p nil) - (*print-pretty* original-print-pretty)) - - ;; 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) - - ;; (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.) - (handler-case - (format *error-output* - "~2&~@~%" - (type-of *debug-condition*) - *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 ~ + (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*))))) - - ;; 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) - - (setf background-p - (sb!thread::debugger-wait-until-foreground-thread *debug-io*)) - (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%" - '*debug-condition* - '*debug-beginner-help-p*)) - (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)) - (when background-p (sb!thread::release-foreground))))))) - -;;; the degenerate case of INVOKE-DEBUGGER, when ordinary ANSI behavior -;;; has been suppressed by command-line --disable-debugger option -(defun invoke-debugger/disabled (condition) + 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 (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO* + ;; here as well, but that is probably bogus since it + ;; removes the users ability to do output to a redirected + ;; *S-O*. Now we just rebind it so that users can temporarily + ;; frob it. FIXME: This and other "what gets bound when" + ;; behaviour should be documented in the manual. + (*standard-output* *standard-output*) + ;; This seems reasonable: e.g. if the user has redirected + ;; *ERROR-OUTPUT* to some log file, it's probably wrong + ;; to send errors which occur in interactive debugging to + ;; that file, and right to send them to *DEBUG-IO*. + (*error-output* *debug-io*)) + (unless (typep condition 'step-condition) + (when *debug-beginner-help-p* + (format *debug-io* + "~%~@~2%")) + (show-restarts *debug-restarts* *debug-io*)) + (internal-debug)) + (when background-p + (sb!thread::release-foreground)))))) + +;;; 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) @@ -806,8 +587,9 @@ reset to ~S." (handler-case (progn (format *error-output* - "~&~@~2%" + "~&~@~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 @@ -848,13 +630,15 @@ reset to ~S." ;;; halt-on-failures and prompt-on-failures modes, suitable for ;;; noninteractive and interactive use respectively (defun disable-debugger () - (setf (fdefinition 'invoke-debugger) #'invoke-debugger/disabled - *debug-io* *error-output*)) + (when (eql *invoke-debugger-hook* nil) + (setf *debug-io* *error-output* + *invoke-debugger-hook* 'debugger-disabled-hook))) + (defun enable-debugger () - (setf (fdefinition 'invoke-debugger) #'invoke-debugger/enabled - *debug-io* *query-io*)) -;;; The enabled mode is the ANSI default. -(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) @@ -885,6 +669,9 @@ reset to ~S." (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 @@ -918,19 +705,17 @@ reset to ~S." (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) + (fresh-line *debug-io*) + (print-frame-call *current-frame* *debug-io* :verbosity 2) (loop (catch 'debug-loop-catcher (handler-bind ((error (lambda (condition) (when *flush-debug-errors* (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t + (princ condition *debug-io*) + (format *debug-io* "~&error flushed (because ~ - ~S is set)" + ~S is set)" '*flush-debug-errors*) (/show0 "throwing DEBUG-LOOP-CATCHER") (throw 'debug-loop-catcher nil))))) @@ -948,37 +733,23 @@ reset to ~S." (cond ((not cmd-fun) (debug-eval-print exp)) ((consp cmd-fun) - (format t "~&Your command, ~S, is ambiguous:~%" + (format *debug-io* + "~&Your command, ~S, is ambiguous:~%" exp) (dolist (ele cmd-fun) - (format t " ~A~%" ele))) + (format *debug-io* " ~A~%" ele))) (t (funcall cmd-fun)))))))))))) -(defvar *debug-loop-fun* #'debug-loop-fun - "a function taking no parameters that starts the low-level debug loop") - ;;; 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)) - (setq +++ ++ ++ + + - - expr) - (let* ((values (multiple-value-list (eval -))) - (*standard-output* *debug-io*)) + (let ((values (multiple-value-list + (interactive-eval (sb!di:preprocess-for-eval expr))))) (/noshow "done with EVAL in DEBUG-EVAL-PRINT") - (fresh-line) - (if values (prin1 (car values))) - (dolist (x (cdr values)) - (fresh-line) - (prin1 x)) - (setq /// // // / / values) - (setq *** ** ** * * (car values)) - ;; Make sure that nobody passes back an unbound marker. - (unless (boundp '*) - (setq * nil) - (fresh-line) - ;; FIXME: The way INTERACTIVE-EVAL does this seems better. - (princ "Setting * to NIL (was unbound marker).")))) + (dolist (value values) + (fresh-line *debug-io*) + (prin1 value)))) ;;;; debug loop functions @@ -1243,17 +1014,17 @@ reset to ~S." (let ((next (sb!di:frame-up *current-frame*))) (cond (next (setf *current-frame* next) - (print-frame-call next)) + (print-frame-call next *debug-io*)) (t - (format t "~&Top of stack."))))) + (format *debug-io* "~&Top of stack."))))) (!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next (setf *current-frame* next) - (print-frame-call next)) + (print-frame-call next *debug-io*)) (t - (format t "~&Bottom of stack."))))) + (format *debug-io* "~&Bottom of stack."))))) (!def-debug-command-alias "D" "DOWN") @@ -1265,14 +1036,14 @@ reset to ~S." ;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead))) ;;; ((null lead) ;;; (setf *current-frame* prev) -;;; (print-frame-call prev)))) +;;; (print-frame-call prev *debug-io*)))) (!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)))) + (print-frame-call prev *debug-io*)))) (!def-debug-command-alias "B" "BOTTOM") @@ -1290,11 +1061,11 @@ reset to ~S." (cond (next-frame (setf frame next-frame)) (t - (format t + (format *debug-io* "The ~A of the stack was encountered.~%" limit-string) (return frame))))))) - (print-frame-call *current-frame*)) + (print-frame-call *current-frame* *debug-io*)) (!def-debug-command-alias "F" "FRAME") @@ -1333,16 +1104,13 @@ reset to ~S." (string= (symbol-name sym1) (symbol-name sym2))))) (t - (format t "~S is invalid as a restart name.~%" num) + (format *debug-io* "~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 - ;; shouldn't go to *STANDARD-OUTPUT*, but *ERROR-OUTPUT* or - ;; *QUERY-IO* or something. Look through this file to - ;; straighten out stream usage. - (princ "There is no such restart."))))) + (princ "There is no such restart." *debug-io*))))) ;;;; information commands @@ -1367,7 +1135,7 @@ reset to ~S." (backtrace (read-if-available most-positive-fixnum))) (!def-debug-command "PRINT" () - (print-frame-call *current-frame*)) + (print-frame-call *current-frame* *debug-io*)) (!def-debug-command-alias "P" "PRINT") @@ -1385,7 +1153,7 @@ reset to ~S." (setf any-p t) (when (eq (sb!di:debug-var-validity v location) :valid) (setf any-valid-p t) - (format t "~S~:[#~W~;~*~] = ~S~%" + (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" (sb!di:debug-var-symbol v) (zerop (sb!di:debug-var-id v)) (sb!di:debug-var-id v) @@ -1393,21 +1161,24 @@ reset to ~S." (cond ((not any-p) - (format t "There are no local variables ~@[starting with ~A ~]~ - in the function." + (format *debug-io* + "There are no local variables ~@[starting with ~A ~]~ + in the function." prefix)) ((not any-valid-p) - (format t "All variables ~@[starting with ~A ~]currently ~ - have invalid values." + (format *debug-io* + "All variables ~@[starting with ~A ~]currently ~ + have invalid values." prefix)))) - (write-line "There is no variable information available.")))) + (write-line "There is no variable information available." + *debug-io*)))) (!def-debug-command-alias "L" "LIST-LOCALS") (!def-debug-command "SOURCE" () - (fresh-line) - (print-code-location-source-form (sb!di:frame-code-location *current-frame*) - (read-if-available 0))) + (print (code-location-source-form (sb!di:frame-code-location *current-frame*) + (read-if-available 0)) + *debug-io*)) ;;;; source location printing @@ -1431,10 +1202,11 @@ reset to ~S." (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)) - *before-save-initializations*) +;;; 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 @@ -1485,7 +1257,7 @@ reset to ~S." (setq *cached-source-stream* (open name :if-does-not-exist nil)) (unless *cached-source-stream* (error "The source file no longer exists:~% ~A" (namestring name))) - (format t "~%; file: ~A~%" (namestring name))) + (format *debug-io* "~%; file: ~A~%" (namestring name))) (setq *cached-debug-source* (if (= (sb!di:debug-source-created d-source) @@ -1496,8 +1268,9 @@ reset to ~S." ((eq *cached-debug-source* d-source) (file-position *cached-source-stream* char-offset)) (t - (format t "~%; File has been modified since compilation:~%; ~A~@ - ; Using form offset instead of character position.~%" + (format *debug-io* + "~%; File has been modified since compilation:~%; ~A~@ + ; Using form offset instead of character position.~%" (namestring name)) (file-position *cached-source-stream* 0) (let ((*read-suppress* t)) @@ -1515,220 +1288,26 @@ reset to ~S." (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) -(defun print-code-location-source-form (location context) +(defun 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-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))))) + (sb!di:source-path-context form + (svref translations form-num) + context)))) -;;; breakpoint and step commands - -;;; Step to the next code-location. +;;; step to the next steppable form (!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 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-fun*))) - (cond ((consp df) - (setf df (sb!di:fun-debug-fun (eval df))) - (setf *default-breakpoint-debug-fun* df)) - ((or (eq ':c df) - (not *default-breakpoint-debug-fun*)) - (setf df (sb!di:frame-debug-fun *current-frame*)) - (setf *default-breakpoint-debug-fun* 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-fun* - *breakpoints* :fun-start)) - (here (sb!di:code-location= - (sb!di:debug-fun-start-location - *default-breakpoint-debug-fun*) continue-at))) - (when (or active here) - (format t "::FUN-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 "~&~W: " prev-num) - (format t "~&~W-~W: " 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-toplevel-form-offset - code-location) - (sb!di:code-location-toplevel-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-fun* - *breakpoints* - :fun-end) - (format t "~&::FUN-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-fun*)) - (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-fun* - (sb!di:fun-debug-fun function)) - (setf place *default-breakpoint-debug-fun*) - (setf *possible-breakpoints* - (possible-breakpoints - *default-breakpoint-debug-fun*)))))) - (setup-fun-start () - (let ((code-loc (sb!di:debug-fun-start-location place))) - (setf bp (sb!di:make-breakpoint #'main-hook-fun - place - :kind :fun-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-fun-end () - (setf bp - (sb!di:make-breakpoint #'main-hook-fun - place - :kind :fun-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-fun 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-fun-start)) - ((or (eq index :end) (eq index :e)) - (setup-fun-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.")) + (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" () @@ -1737,7 +1316,7 @@ reset to ~S." (function (sb!di:debug-fun-fun debug-fun))) (if function (describe function) - (format t "can't figure out the function for this frame")))) + (format *debug-io* "can't figure out the function for this frame")))) (!def-debug-command "SLURP" () (loop while (read-char-no-hang *standard-input*))) @@ -1756,16 +1335,17 @@ reset to ~S." return (sb!di:frame-code-location *current-frame*)) *current-frame*)) - (format t "~@")))) + (format *debug-io* + "~@")))) ;;;; debug loop command utilities (defun read-prompting-maybe (prompt) (unless (sb!int:listen-skip-whitespace *debug-io*) - (princ prompt) - (force-output)) + (princ prompt *debug-io*) + (force-output *debug-io*)) (read *debug-io*)) (defun read-if-available (default)