X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=76a87d8610c9e9551db8bd5dc938c9a5e70fa547;hb=842c9ee088e4b85cc0ef4ba9ce69797b6f26e677;hp=4943a5120bd926ff39a03b1cdb214f62a0914aec;hpb=06ab5194e064ef8855d6952d02f9cae55e8e75e4;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 4943a51..76a87d8 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -24,19 +24,27 @@ ;;; * As condition :REPORT methods are converted to use the pretty ;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under ;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an -;;; ARG-COUNT-ERROR printed as +;;; ARG-COUNT-ERROR printed as ;;; error while parsing arguments to DESTRUCTURING-BIND: ;;; invalid number of elements in ;;; # ;;; 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, @@ -54,12 +62,13 @@ ;;; 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. +;;; If this is bound before the debugger is invoked, it is used as the stack +;;; top by the debugger. It can either be the first interesting frame, or the +;;; name of the last uninteresting frame. (defvar *stack-top-hint* nil) -(defvar *stack-top* nil) (defvar *real-stack-top* nil) +(defvar *stack-top* nil) (defvar *current-frame* nil) @@ -71,175 +80,78 @@ "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*)) - + "~%~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 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 friends, but evaluation in the debug loop - does affect these variables. + to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to + its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*. +Debug commands do not affect *, //, and similar variables, but evaluation in + the debug loop does affect these variables. 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. 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). - 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. + TOPLEVEL, TOP exits debugger and returns to top level REPL + RESTART invokes restart numbered as shown (prompt if not given). + ERROR prints the error condition and restart cases. + + 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 - 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: + START Selects the CONTINUE restart if one exists and starts + single-stepping. Single stepping affects only code compiled with + under high DEBUG optimization quality. See User Manual for details. + STEP Steps into the current form. + NEXT Steps over the current form. + OUT Stops stepping temporarily, but resumes it when the topmost frame that + was stepped into returns. + STOP Stops single-stepping. Function and macro commands: - (SB-DEBUG: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.") - -;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. -(define-condition step-condition (simple-condition) ()) + Returns the value of the specified variable in the current frame. + +Other commands: + RETURN expr + Return the values resulting from evaluation of expr from the + current frame, if this frame was compiled with a sufficiently high + DEBUG optimization quality. + + RESTART-FRAME + Restart execution of the current frame, if this frame is for a + global function which 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.)") -;;;; 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 @@ -247,214 +159,272 @@ Function and macro commands: (defun maybe-block-start-location (loc) (if (sb!di:code-location-unknown-p loc) (let* ((block (sb!di:code-location-debug-block loc)) - (start (sb!di:do-debug-block-locations (loc block) - (return loc)))) - (cond ((and (not (sb!di:debug-block-elsewhere-p block)) - start) - ;; FIXME: Why output on T instead of *DEBUG-FOO* or something? - (format t "~%unknown location: using block start~%") - start) - (t - loc))) + (start (sb!di:do-debug-block-locations (loc block) + (return loc)))) + (cond ((and (not (sb!di:debug-block-elsewhere-p block)) + start) + (format *debug-io* "~%unknown location: using block start~%") + start) + (t + loc))) loc)) -;;;; the BREAKPOINT-INFO structure - -;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil)) - ;; where we are going to stop - (place (missing-arg) :type (or sb!di:code-location sb!di:debug-fun)) - ;; the breakpoint returned by sb!di:make-breakpoint - (breakpoint (missing-arg) :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 (missing-arg) :type (or symbol integer)) - ;; the number used when listing the breakpoints active and to delete - ;; breakpoints - (breakpoint-number (missing-arg) :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-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) - "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*)) +(declaim (unsigned-byte *backtrace-frame-count*)) +(defvar *backtrace-frame-count* 1000 + "Default number of frames to backtrace. Defaults to 1000.") + +(declaim (type (member :minimal :normal :full) *method-frame-style*)) +(defvar *method-frame-style* :normal + "Determines how frames corresponding to method functions are represented in +backtraces. Possible values are :MINIMAL, :NORMAL, and :FULL. + + :MINIMAL represents them as + + ( ...args...) + + if all arguments are available, and only a single method is applicable to + the arguments -- otherwise behaves as :NORMAL. + + :NORMAL represents them as + + ((:method [*] (*)) ...args...) + + The frame is then followed by either [fast-method] or [slow-method], + designating the kind of method function. (See below.) + + :FULL represents them using the actual funcallable method function name: + + ((sb-pcl:fast-method [*] (*)) ...args...) + + or + + ((sb-pcl:slow-method [*] (*)) ...args...) + + In the this case arguments may include values internal to SBCL's method + dispatch machinery.") + +(define-deprecated-variable :early "1.1.4.9" *show-entry-point-details* + :value nil) + +(defun backtrace (&optional (count *backtrace-frame-count*) (stream *debug-io*)) + "Replaced by PRINT-BACKTRACE, will eventually be deprecated." + (print-backtrace :count count :stream stream)) + +(defun backtrace-as-list (&optional (count *backtrace-frame-count*)) + "Replaced by LIST-BACKTRACE, will eventually be deprecated." + (list-backtrace :count count)) + +(defun backtrace-start-frame (frame-designator) + (let ((here (sb!di:top-frame))) + (labels ((current-frame () + (let ((frame here)) + ;; Our caller's caller. + (loop repeat 2 + do (setf frame (or (sb!di:frame-down frame) frame))) + frame)) + (interrupted-frame () + (or (nth-value 1 (find-interrupted-name-and-frame)) + (current-frame)))) + (cond ((eq :current-frame frame-designator) + (current-frame)) + ((eq :interrupted-frame frame-designator) + (interrupted-frame)) + ((eq :debugger-frame frame-designator) + (if (and *in-the-debugger* *current-frame*) + *current-frame* + (interrupted-frame))) + ((sb!di:frame-p frame-designator) + frame-designator) + (t + (error "Invalid designator for initial backtrace frame: ~S" + frame-designator)))))) + +(defun map-backtrace (function &key + (start 0) + (from :debugger-frame) + (count *backtrace-frame-count*)) #!+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*) - (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*) + "Calls the designated FUNCTION with each frame on the call stack. +Returns the last value returned by FUNCTION. + +COUNT is the number of frames to backtrace, defaulting to +*BACKTRACE-FRAME-COUNT*. + +START is the number of the frame the backtrace should start from. + +FROM specifies the frame relative to which the frames are numbered. Possible +values are an explicit SB-DI:FRAME object, and the +keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default +is :DEBUGGER-FRAME. + + :CURRENT-FRAME + specifies the caller of MAP-BACKTRACE. + + :INTERRUPTED-FRAME + specifies the first interrupted frame on the stack \(typically the frame + where the error occured, as opposed to error handling frames) if any, + otherwise behaving as :CURRENT-FRAME. + + :DEBUGGER-FRAME + specifies the currently debugged frame when inside the debugger, and + behaves as :INTERRUPTED-FRAME outside the debugger. +" + (loop with result = nil + for index upfrom 0 + for frame = (backtrace-start-frame from) + then (sb!di:frame-down frame) + until (null frame) + when (<= start index) do + (if (minusp (decf count)) + (return result) + (setf result (funcall function frame))) + finally (return result))) + +(defun print-backtrace (&key + (stream *debug-io*) + (start 0) + (from :debugger-frame) + (count *backtrace-frame-count*) + (print-thread t) + (print-frame-source nil) + (method-frame-style *method-frame-style*)) + #!+sb-doc + "Print a listing of the call stack to STREAM, defaulting to *DEBUG-IO*. + +COUNT is the number of frames to backtrace, defaulting to +*BACKTRACE-FRAME-COUNT*. + +START is the number of the frame the backtrace should start from. + +FROM specifies the frame relative to which the frames are numbered. Possible +values are an explicit SB-DI:FRAME object, and the +keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default +is :DEBUGGER-FRAME. + + :CURRENT-FRAME + specifies the caller of PRINT-BACKTRACE. + + :INTERRUPTED-FRAME + specifies the first interrupted frame on the stack \(typically the frame + where the error occured, as opposed to error handling frames) if any, + otherwise behaving as :CURRENT-FRAME. + + :DEBUGGER-FRAME + specifies the currently debugged frame when inside the debugger, and + behaves as :INTERRUPTED-FRAME outside the debugger. + +If PRINT-THREAD is true (default), backtrace is preceded by printing the +thread object the backtrace is from. + +If PRINT-FRAME-SOURCE is true (default is false), each frame is followed by +printing the currently executing source form in the function responsible for +that frame, when available. Requires the function to have been compiled at +DEBUG 2 or higher. If PRINT-FRAME-SOURCE is :ALWAYS, it also reports \"no +source available\" for frames for which were compiled at lower debug settings. + +METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames +corresponding to method functions are printed. Possible values +are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more +information." + (fresh-line stream) + (when print-thread + (format stream "Backtrace for: ~S~%" sb!thread:*current-thread*)) + (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*) + *suppress-print-errors* + 'serious-condition)) + (*print-circle* t) + (n start)) + (handler-bind ((print-not-readable #'print-unreadably)) + (map-backtrace (lambda (frame) + (print-frame-call frame stream + :number n + :method-frame-style method-frame-style + :print-frame-source print-frame-source) + (incf n)) + :from (backtrace-start-frame from) + :start start + :count count))) + (fresh-line stream) (values)) + +(defun list-backtrace (&key + (count *backtrace-frame-count*) + (start 0) + (from :debugger-frame) + (method-frame-style *method-frame-style*)) + #!+sb-doc + "Returns a list describing the call stack. Each frame is represented +by a sublist: + + \( ...args...) + +where the name describes the function responsible for the frame. The name +might not be bound to the actual function object. Unavailable arguments are +represented by dummy objects that print as #. Objects +with dynamic-extent allocation by the current thread are represented by +substitutes to avoid references to them from leaking outside their legal +extent. + +COUNT is the number of frames to backtrace, defaulting to +*BACKTRACE-FRAME-COUNT*. + +START is the number of the frame the backtrace should start from. + +FROM specifies the frame relative to which the frames are numbered. Possible +values are an explicit SB-DI:FRAME object, and the +keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default +is :DEBUGGER-FRAME. + + :CURRENT-FRAME + specifies the caller of LIST-BACKTRACE. + + :INTERRUPTED-FRAME + specifies the first interrupted frame on the stack \(typically the frame + where the error occured, as opposed to error handling frames) if any, + otherwise behaving as :CURRENT-FRAME. + + :DEBUGGER-FRAME + specifies the currently debugged frame when inside the debugger, and + behaves as :INTERRUPTED-FRAME outside the debugger. + +METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames +corresponding to method functions are printed. Possible values +are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more +information." + (let (rbacktrace) + (map-backtrace + (lambda (frame) + (push (frame-call-as-list frame :method-frame-style method-frame-style) + rbacktrace)) + :count count + :start start + :from (backtrace-start-frame from)) + (nreverse rbacktrace))) + +(defun frame-call-as-list (frame &key (method-frame-style *method-frame-style*)) + (multiple-value-bind (name args info) + (frame-call frame :method-frame-style method-frame-style + :replace-dynamic-extent-objects t) + (values (cons name args) info))) + +(defun replace-dynamic-extent-object (obj) + (if (stack-allocated-p obj) + (make-unprintable-object + (handler-case + (format nil "dynamic-extent: ~S" obj) + (error () + "error printing dynamic-extent object"))) + obj)) + +(defun stack-allocated-p (obj) + "Returns T if OBJ is allocated on the stack of the current +thread, NIL otherwise." + (with-pinned-objects (obj) + (let ((sap (int-sap (get-lisp-obj-address obj)))) + (when (sb!vm:control-stack-pointer-valid-p sap nil) + t)))) ;;;; frame printing @@ -463,20 +433,22 @@ Function and macro commands: ;;; This is a convenient way to express what to do for each type of ;;; lambda-list element. (sb!xc:defmacro lambda-list-element-dispatch (element - &key - required - optional - rest - keyword - deleted) + &key + required + optional + rest + keyword + more + deleted) `(etypecase ,element (sb!di:debug-var ,@required) (cons (ecase (car ,element) - (:optional ,@optional) - (:rest ,@rest) - (:keyword ,@keyword))) + (:optional ,@optional) + (:rest ,@rest) + (:keyword ,@keyword) + (:more ,@more))) (symbol (aver (eq ,element :deleted)) ,@deleted))) @@ -485,80 +457,166 @@ Function and macro commands: (let ((var (gensym))) `(let ((,var ,variable)) (cond ((eq ,var :deleted) ,deleted) - ((eq (sb!di:debug-var-validity ,var ,location) :valid) - ,valid) - (t ,other))))) + ((eq (sb!di:debug-var-validity ,var ,location) :valid) + ,valid) + (t ,other))))) ) ; EVAL-WHEN -;;; This is used in constructing arg lists for debugger printing when -;;; the arg list is unavailable, some arg is unavailable or unused, etc. -(defstruct (unprintable-object - (:constructor make-unprintable-object (string)) - (:print-object (lambda (x s) - (print-unreadable-object (x s) - (write-string (unprintable-object-string x) - s)))) - (:copier nil)) - string) - -;;; 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)) - (loc (sb!di:frame-code-location frame)) - (reversed-args nil)) - - ;; Construct function arguments in REVERSED-ARGS. - (handler-case - (dolist (ele (sb!di:debug-fun-lambda-list debug-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) reversed-args)) - :optional ((push (frame-call-arg (second ele) loc frame) - reversed-args)) - :keyword ((push (second ele) reversed-args) - (push (frame-call-arg (third ele) loc frame) - reversed-args)) - :deleted ((push (frame-call-arg ele loc frame) reversed-args)) - :rest ((lambda-var-dispatch (second ele) loc - nil - (progn - (setf reversed-args - (append (reverse (sb!di:debug-var-value - (second ele) frame)) - reversed-args)) - (return)) - (push (make-unprintable-object - "unavailable &REST argument") - reversed-args))))) - (sb!di:lambda-list-unavailable - () - (push (make-unprintable-object "lambda list unavailable") - reversed-args))) - - (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args)))) - ;; 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. - (format t "~{ ~_~S~}" args))) - - (when (sb!di:debug-fun-kind debug-fun) - (write-char #\[) - (prin1 (sb!di:debug-fun-kind debug-fun)) - (write-char #\])))) +;;; Extract the function argument values for a debug frame. +(defun map-frame-args (thunk frame) + (let ((debug-fun (sb!di:frame-debug-fun frame))) + (dolist (element (sb!di:debug-fun-lambda-list debug-fun)) + (funcall thunk element)))) + +(defun frame-args-as-list (frame) + (handler-case + (let ((location (sb!di:frame-code-location frame)) + (reversed-result nil)) + (block enumerating + (map-frame-args + (lambda (element) + (lambda-list-element-dispatch element + :required ((push (frame-call-arg element location frame) reversed-result)) + :optional ((push (frame-call-arg (second element) location frame) + reversed-result)) + :keyword ((push (second element) reversed-result) + (push (frame-call-arg (third element) location frame) + reversed-result)) + :deleted ((push (frame-call-arg element location frame) reversed-result)) + :rest ((lambda-var-dispatch (second element) location + nil + (let ((rest (sb!di:debug-var-value (second element) frame))) + (if (listp rest) + (setf reversed-result (append (reverse rest) reversed-result)) + (push (make-unprintable-object "unavailable &REST argument") + reversed-result)) + (return-from enumerating)) + (push (make-unprintable-object + "unavailable &REST argument") + reversed-result))) + :more ((lambda-var-dispatch (second element) location + nil + (let ((context (sb!di:debug-var-value (second element) frame)) + (count (sb!di:debug-var-value (third element) frame))) + (setf reversed-result + (append (reverse + (multiple-value-list + (sb!c::%more-arg-values context 0 count))) + reversed-result)) + (return-from enumerating)) + (push (make-unprintable-object "unavailable &MORE argument") + reversed-result))))) + frame)) + (nreverse reversed-result)) + (sb!di:lambda-list-unavailable () + (make-unprintable-object "unavailable lambda list")))) + +(defun clean-xep (name args info) + (values (second name) + (if (consp args) + (let* ((count (first args)) + (real-args (rest args))) + (if (fixnump count) + ;; So, this is a cheap trick -- but makes backtraces for + ;; too-many-arguments-errors much, much easier to to + ;; understand. FIXME: For :EXTERNAL frames at least we + ;; should be able to get the actual arguments, really. + (loop repeat count + for arg = (if real-args + (pop real-args) + (make-unprintable-object "unknown")) + collect arg) + real-args)) + args) + (if (eq (car name) 'sb!c::tl-xep) + (cons :tl info) + info))) + +(defun clean-&more-processor (name args info) + (values (second name) + (if (consp args) + (let* ((more (last args 2)) + (context (first more)) + (count (second more))) + (append + (butlast args 2) + (if (fixnump count) + (multiple-value-list + (sb!c:%more-arg-values context 0 count)) + (list + (make-unprintable-object "more unavailable arguments"))))) + args) + (cons :more info))) + +(defun clean-fast-method (name args style info) + (multiple-value-bind (cname cargs) + (ecase style + (:minimal + (let ((gf-name (second name)) + (real-args (cddr args))) + (if (and (fboundp gf-name) + (notany #'sb!impl::unprintable-object-p real-args) + (let ((methods (compute-applicable-methods + (fdefinition gf-name) real-args))) + (and methods (not (cdr methods))))) + (values gf-name real-args) + (values (cons :method (cdr name)) real-args)))) + (:normal + (values (cons :method (cdr name)) (cddr args))) + (:full + (values name args))) + (values cname cargs (cons :fast-method info)))) + +(defun clean-frame-call (name args method-frame-style info) + (if (consp name) + (case (first name) + ((sb!c::xep sb!c::tl-xep) + (clean-xep name args info)) + ((sb!c::&more-processor) + (clean-&more-processor name args info)) + ((sb!c::&optional-processor) + (clean-frame-call (second name) args method-frame-style + info)) + ((sb!pcl::fast-method) + (clean-fast-method name args method-frame-style info)) + (t + (values name args info))) + (values name args info))) + +(defun frame-call (frame &key (method-frame-style *method-frame-style*) + replace-dynamic-extent-objects) + "Returns as multiple values a descriptive name for the function responsible +for FRAME, arguments that that function, and a list providing additional +information about the frame. + +Unavailable arguments are represented using dummy-objects printing as +#. + +METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames +corresponding to method functions are printed. Possible values +are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more +information. + +If REPLACE-DYNAMIC-EXTENT-OBJECTS is true, objects allocated on the stack of +the current thread are replaced with dummy objects which can safely escape." + (let* ((debug-fun (sb!di:frame-debug-fun frame)) + (kind (sb!di:debug-fun-kind debug-fun))) + (multiple-value-bind (name args info) + (clean-frame-call (sb!di:debug-fun-name debug-fun) + (frame-args-as-list frame) + method-frame-style + (when kind (list kind))) + (let ((args (if (and (consp args) replace-dynamic-extent-objects) + (mapcar #'replace-dynamic-extent-object args) + args))) + (values name args info))))) (defun ensure-printable-object (object) (handler-case (with-open-stream (out (make-broadcast-stream)) - (prin1 object out) - object) + (prin1 object out) + object) (error (cond) (declare (ignore cond)) (make-unprintable-object "error printing object")))) @@ -574,25 +632,50 @@ Function and macro 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))) - (when (>= verbosity 2) +(defun print-frame-call (frame stream + &key print-frame-source + number + (method-frame-style *method-frame-style*)) + (when number + (format stream "~&~S: " (if (integerp number) + number + (sb!di:frame-number frame)))) + (multiple-value-bind (name args info) + (frame-call frame :method-frame-style method-frame-style) + (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) + (*print-pretty* nil) + (*print-circle* t) + (name (ensure-printable-object name))) + (write name :stream stream :escape t :pretty (equal '(lambda ()) name)) + ;; 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 info + (format stream " [~{~(~A~)~^,~}]" info))) + (when print-frame-source (let ((loc (sb!di:frame-code-location frame))) (handler-case - (progn - (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)))))) + (let ((source (handler-case + (code-location-source-form loc 0) + (error (c) + (format stream "~& error finding frame source: ~A" c))))) + (format stream "~% source: ~S" source)) + (sb!di:debug-condition () + ;; This is mostly noise. + (when (eq :always print-frame-source) + (format stream "~& no source available for frame"))) + (error (c) + (format stream "~& error printing frame source: ~A" c)))))) ;;;; INVOKE-DEBUGGER @@ -604,157 +687,358 @@ 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 + (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))))))) + +;;; This function is not inlined so it shows up in the backtrace; that +;;; can be rather handy when one has to debug the interplay between +;;; *INVOKE-DEBUGGER-HOOK* and *DEBUGGER-HOOK*. +(declaim (notinline run-hook)) +(defun run-hook (variable condition) + (let ((old-hook (symbol-value variable))) + (when old-hook + (progv (list variable) (list nil) + (funcall old-hook condition old-hook))))) + +;;; We can bind *stack-top-hint* to a symbol, in which case this function will +;;; resolve that hint lazily before we enter the debugger. +(defun resolve-stack-top-hint () + (let ((hint *stack-top-hint*) + (*stack-top-hint* nil)) + (cond + ;; No hint, just keep the debugger guts out. + ((not hint) + (find-caller-name-and-frame)) + ;; Interrupted. Look for the interrupted frame -- if we don't find one + ;; this falls back to the next case. + ((and (eq hint 'invoke-interruption) + (nth-value 1 (find-interrupted-name-and-frame)))) + ;; Name of the first uninteresting frame. + ((symbolp hint) + (find-caller-of-named-frame hint)) + ;; We already have a resolved hint. + (t + hint)))) + (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)))) - ;; FIXME: No-one seems to know what this is for. Nothing is noticeably - ;; broken on sunos... - #!-sunos (sb!unix:unix-sigsetmask 0) - - ;; 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 + + (let ((*stack-top-hint* (resolve-stack-top-hint))) + + ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not + ;; called when the debugger is disabled + (run-hook '*invoke-debugger-hook* condition) + (run-hook '*debugger-hook* condition) + + ;; 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*)) - (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX. - (original-package *package*)) - (with-standard-io-syntax - (let* ((*debug-condition* condition) - (*debug-restarts* (compute-restarts condition)) - ;; We want the i/o subsystem to be in a known, useful - ;; state, regardless of where the debugger was invoked in - ;; the program. WITH-STANDARD-IO-SYNTAX does some of that, - ;; but - ;; 1. It doesn't affect our internal special variables - ;; like *CURRENT-LEVEL-IN-PRINT*. - ;; 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-in-print* 0) - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) - (*readtable* *debug-readtable*) - (*print-readably* nil) - (*print-pretty* t) - (*package* original-package) - (*nested-debug-condition* nil)) - - ;; Before we start our own output, finish any pending output. - ;; Otherwise, if the user tried to track the progress of - ;; his program using PRINT statements, he'd tend to lose - ;; the last line of output or so, and get confused. - (flush-standard-output-streams) - - ;; (The initial output here goes to *ERROR-OUTPUT*, because the - ;; initial output is not interactive, just an error message, - ;; and when people redirect *ERROR-OUTPUT*, they could - ;; reasonably expect to see error messages logged there, - ;; regardless of what the debugger does afterwards.) - (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 ~ + '*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 %print-debugger-invocation-reason (condition stream) + (format stream "~2&") + ;; Note: Ordinarily it's only a matter of taste whether to use + ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but + ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is + ;; definitely preferred, because the FORMAT alternative was acting odd. + (pprint-logical-block (stream nil) + (format stream + "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A" + (type-of condition) + #!+sb-thread sb!thread:*current-thread* + #!-sb-thread nil + condition)) + (terpri stream)) + +(defun %invoke-debugger (condition) + (let ((*debug-condition* condition) + (*debug-restarts* (compute-restarts condition)) + (*nested-debug-condition* nil)) + (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.) + (unless (typep condition 'step-condition) + (%print-debugger-invocation-reason condition *error-output*)) + (error (condition) + (setf *nested-debug-condition* condition) + (let ((ndc-type (type-of *nested-debug-condition*))) + (format *error-output* + "~&~@<(A ~S was caught when trying to print ~S when ~ 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) - (let (;; FIXME: The first two bindings here seem wrong, - ;; violating the principle of least surprise, and making - ;; it impossible for the user to do reasonable things - ;; like using PRINT at the debugger prompt to send output - ;; to the program's ordinary (possibly - ;; redirected-to-a-file) *STANDARD-OUTPUT*, or using - ;; PEEK-CHAR or some such thing on the program's ordinary - ;; (possibly also redirected) *STANDARD-INPUT*. - (*standard-input* *debug-io*) - (*standard-output* *debug-io*) - ;; This seems reasonable: e.g. if the user has redirected - ;; *ERROR-OUTPUT* to some log file, it's probably wrong - ;; to send errors which occur in interactive debugging to - ;; that file, and right to send them to *DEBUG-IO*. - (*error-output* *debug-io*)) - (unless (typep condition 'step-condition) - (when *debug-beginner-help-p* - (format *debug-io* - "~%~@~2%" - '*debug-condition* - '*debug-beginner-help-p*)) - (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)))))) + ndc-type + '*debug-condition* + ndc-type + '*nested-debug-condition*)) + (when (typep *nested-debug-condition* 'cell-error) + ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE: + (format *error-output* + "~&(CELL-ERROR-NAME ~S) = ~S~%" + '*nested-debug-condition* + (cell-error-name *nested-debug-condition*))))) + + (let ((background-p (sb!thread::debugger-wait-until-foreground-thread + *debug-io*))) + + ;; 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 abort) + (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") + (exit :code 1 :abort abort))) + ;; 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 sb!thread:*current-thread* + #!-sb-thread nil + condition) + ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that + ;; even if we hit an error within BACKTRACE (e.g. a bug in + ;; the debugger's own frame-walking code, or a bug in a user + ;; PRINT-OBJECT method) we'll at least have the CONDITION + ;; printed out before we die. + (finish-output *error-output*) + ;; (Where to truncate the BACKTRACE is of course arbitrary, but + ;; it seems as though we should at least truncate it somewhere.) + (print-backtrace :count 128 :stream *error-output* + :from :interrupted-frame) + (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 :abort t))))) + +(defvar *old-debugger-hook* nil) + +;;; halt-on-failures and prompt-on-failures modes, suitable for +;;; noninteractive and interactive use respectively +(defun disable-debugger () + "When invoked, this function will turn off both the SBCL debugger +and LDB (the low-level debugger). See also ENABLE-DEBUGGER." + ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort + ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had + ;; to set it to a suitable value again and be very careful, + ;; especially if the user has also set it. -- MG 2005-07-15 + (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *old-debugger-hook* *invoke-debugger-hook* + *invoke-debugger-hook* 'debugger-disabled-hook)) + ;; This is not inside the UNLESS to ensure that LDB is disabled + ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was. + ;; This might matter for example when restoring a core. + (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler" + (function sb!alien:void)))) + +(defun enable-debugger () + "Restore the debugger if it has been turned off by DISABLE-DEBUGGER." + (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *invoke-debugger-hook* *old-debugger-hook* + *old-debugger-hook* nil)) + (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler" + (function sb!alien:void)))) (defun show-restarts (restarts s) (cond ((null restarts) - (format s - "~&(no restarts: If you didn't do this on purpose, ~ + (format s + "~&(no restarts: If you didn't do this on purpose, ~ please report it as a bug.)~%")) - (t - (format s "~&restarts:~%") - (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)))))) + (t + (format s "~&restarts (invokable by number or by ~ + possibly-abbreviated name):~%") + (let ((count 0) + (names-used '(nil)) + (max-name-len 0)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + (when name + (let ((len (length (princ-to-string name)))) + (when (> len max-name-len) + (setf max-name-len len)))))) + (unless (zerop max-name-len) + (incf max-name-len 3)) + (dolist (restart restarts) + (let ((name (restart-name restart))) + ;; FIXME: maybe it would be better to display later names + ;; in parens instead of brakets, not just omit them fully. + ;; Call BREAK, call BREAK in the debugger, and tell me + ;; it's not confusing looking. --NS 20050310 + (cond ((member name names-used) + (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) + (t + (format s "~& ~2D: [~VA] ~A~%" + count (- max-name-len 3) name restart) + (push name names-used)))) + (incf count)))))) + +(defvar *debug-loop-fun* #'debug-loop-fun + "a function taking no parameters that starts the low-level debug loop") + +;;; When the debugger is invoked due to a stepper condition, we don't +;;; want to print the current frame before the first prompt for aesthetic +;;; reasons. +(defvar *suppress-frame-print* nil) ;;; This calls DEBUG-LOOP, performing some simple initializations ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into @@ -764,11 +1048,11 @@ reset to ~S." ;;; errors. (defun internal-debug () (let ((*in-the-debugger* t) - (*read-suppress* nil)) + (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - #!-mp (debug-loop) - #!+mp (sb!mp:without-scheduling (debug-loop)))) + (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition))) + (funcall *debug-loop-fun*)))) ;;;; DEBUG-LOOP @@ -779,91 +1063,93 @@ reset to ~S." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") -(defun debug-loop () +(defun debug-read (stream eof-restart) + (declare (type stream stream)) + (let* ((eof-marker (cons nil nil)) + (form (read stream nil eof-marker))) + (if (eq form eof-marker) + (invoke-restart eof-restart) + form))) + +(defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) - (*real-stack-top* (sb!di:top-frame)) - (*stack-top* (or *stack-top-hint* *real-stack-top*)) - (*stack-top-hint* nil) - (*current-frame* *stack-top*)) + (*real-stack-top* (sb!di:top-frame)) + (*stack-top* (or *stack-top-hint* *real-stack-top*)) + (*stack-top-hint* nil) + (*current-frame* *stack-top*)) (handler-bind ((sb!di:debug-condition - (lambda (condition) - (princ condition *debug-io*) - (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil)))) - (fresh-line) - (print-frame-call *current-frame* :verbosity 2) + (lambda (condition) + (princ condition *debug-io*) + (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil)))) + (cond (*suppress-frame-print* + (setf *suppress-frame-print* nil)) + (t + (terpri *debug-io*) + (print-frame-call *current-frame* *debug-io* :print-frame-source t))) (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*) - (/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 - "Reduce debugger level (to debug level ~W)." - level) - (debug-prompt *debug-io*) - (force-output *debug-io*) - (let ((input (sb!int:get-stream-command *debug-io*))) - (cond (input - (let ((cmd-fun (debug-command-p - (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)))))) - (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))))))))))))))) - -;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition *debug-io*) + (format *debug-io* + "~&error flushed (because ~ + ~S is set)" + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + ;; We have to bind LEVEL for the restart function created + ;; by WITH-SIMPLE-RESTART, and we need the explicit ABORT + ;; restart that exists now so that EOF from read can drop + ;; one debugger level. + (let ((level *debug-command-level*) + (restart-commands (make-restart-commands)) + (abort-restart-for-eof (find-restart 'abort))) + (flush-standard-output-streams) + (debug-prompt *debug-io*) + (force-output *debug-io*) + (with-simple-restart (abort + "~@" + level) + (let* ((exp (debug-read *debug-io* abort-restart-for-eof)) + (cmd-fun (debug-command-p exp restart-commands))) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format *debug-io* + "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format *debug-io* " ~A~%" ele))) + (t + (funcall cmd-fun)))))))))))) + +(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.") + +(defun debug-eval (expr) + (cond ((not (and (fboundp 'compile) *auto-eval-in-frame*)) + (eval expr)) + ((frame-has-debug-vars-p *current-frame*) + (sb!di:eval-in-frame *current-frame* expr)) + (t + (format *debug-io* "; No debug variables for current frame: ~ + using EVAL instead of EVAL-IN-FRAME.~%") + (eval expr)))) + (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 expr :eval #'debug-eval)))) (/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-io*))) + (force-output *debug-io*)) ;;;; debug loop functions @@ -874,85 +1160,85 @@ reset to ~S." (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var) `(let* ((temp (etypecase name - (symbol (sb!di:debug-fun-symbol-vars - (sb!di:frame-debug-fun *current-frame*) - name)) - (simple-string (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-fun *current-frame*) - name)))) - (location (sb!di:frame-code-location *current-frame*)) - ;; Let's only deal with valid variables. - (vars (remove-if-not (lambda (v) - (eq (sb!di:debug-var-validity v location) - :valid)) - temp))) + (symbol (sb!di:debug-fun-symbol-vars + (sb!di:frame-debug-fun *current-frame*) + name)) + (simple-string (sb!di:ambiguous-debug-vars + (sb!di:frame-debug-fun *current-frame*) + name)))) + (location (sb!di:frame-code-location *current-frame*)) + ;; Let's only deal with valid variables. + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) + temp))) (declare (list vars)) (cond ((null vars) - (error "No known valid variables match ~S." name)) - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - (t - ;; Since we have more than one, first see whether we have - ;; any variables that exactly match the specification. - (let* ((name (etypecase name - (symbol (symbol-name name)) - (simple-string name))) - ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= - ;; instead. - (exact (remove-if-not (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - name)) - vars)) - (vars (or exact vars))) - (declare (simple-string name) - (list exact vars)) - (cond - ;; Check now for only having one variable. - ((= (length vars) 1) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value (car vars) *current-frame*)) - (:set - `(setf (sb!di:debug-var-value (car vars) *current-frame*) - ,value-var)))) - ;; If there weren't any exact matches, flame about - ;; ambiguity unless all the variables have the same - ;; name. - ((and (not exact) - (find-if-not - (lambda (v) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) - (cdr vars))) - (error "specification ambiguous:~%~{ ~A~%~}" - (mapcar #'sb!di:debug-var-symbol-name - (delete-duplicates - vars :test #'string= - :key #'sb!di:debug-var-symbol-name)))) - ;; All names are the same, so see whether the user - ;; ID'ed one of them. - (id-supplied - (let ((v (find id vars :key #'sb!di:debug-var-id))) - (unless v - (error - "invalid variable ID, ~W: should have been one of ~S" - id - (mapcar #'sb!di:debug-var-id vars))) - ,(ecase ref-or-set - (:ref - '(sb!di:debug-var-value v *current-frame*)) - (:set - `(setf (sb!di:debug-var-value v *current-frame*) - ,value-var))))) - (t - (error "Specify variable ID to disambiguate ~S. Use one of ~S." - name - (mapcar #'sb!di:debug-var-id vars))))))))) + (error "No known valid variables match ~S." name)) + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + (t + ;; Since we have more than one, first see whether we have + ;; any variables that exactly match the specification. + (let* ((name (etypecase name + (symbol (symbol-name name)) + (simple-string name))) + ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/= + ;; instead. + (exact (remove-if-not (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + name)) + vars)) + (vars (or exact vars))) + (declare (simple-string name) + (list exact vars)) + (cond + ;; Check now for only having one variable. + ((= (length vars) 1) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value (car vars) *current-frame*)) + (:set + `(setf (sb!di:debug-var-value (car vars) *current-frame*) + ,value-var)))) + ;; If there weren't any exact matches, flame about + ;; ambiguity unless all the variables have the same + ;; name. + ((and (not exact) + (find-if-not + (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + (sb!di:debug-var-symbol-name (car vars)))) + (cdr vars))) + (error "specification ambiguous:~%~{ ~A~%~}" + (mapcar #'sb!di:debug-var-symbol-name + (delete-duplicates + vars :test #'string= + :key #'sb!di:debug-var-symbol-name)))) + ;; All names are the same, so see whether the user + ;; ID'ed one of them. + (id-supplied + (let ((v (find id vars :key #'sb!di:debug-var-id))) + (unless v + (error + "invalid variable ID, ~W: should have been one of ~S" + id + (mapcar #'sb!di:debug-var-id vars))) + ,(ecase ref-or-set + (:ref + '(sb!di:debug-var-value v *current-frame*)) + (:set + `(setf (sb!di:debug-var-value v *current-frame*) + ,value-var))))) + (t + (error "Specify variable ID to disambiguate ~S. Use one of ~S." + name + (mapcar #'sb!di:debug-var-id vars))))))))) ) ; EVAL-WHEN @@ -984,33 +1270,36 @@ reset to ~S." ;;; 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)) (dolist (ele args (error "The argument specification ~S is out of range." - n)) + n)) (lambda-list-element-dispatch ele - :required ((if (zerop n) (return (values ele t)))) - :optional ((if (zerop n) (return (values (second ele) t)))) - :keyword ((cond ((zerop n) - (return (values (second ele) nil))) - ((zerop (decf n)) - (return (values (third ele) t))))) - :deleted ((if (zerop n) (return (values ele t)))) - :rest ((let ((var (second ele))) - (lambda-var-dispatch var (sb!di:frame-code-location - *current-frame*) - (error "unused &REST argument before n'th -argument") - (dolist (value - (sb!di:debug-var-value var *current-frame*) - (error - "The argument specification ~S is out of range." - n)) - (if (zerop n) - (return-from nth-arg (values value nil)) - (decf n))) - (error "invalid &REST argument before n'th argument"))))) + :required ((if (zerop n) (return (values ele t)))) + :optional ((if (zerop n) (return (values (second ele) t)))) + :keyword ((cond ((zerop n) + (return (values (second ele) nil))) + ((zerop (decf n)) + (return (values (third ele) t))))) + :deleted ((if (zerop n) (return (values ele t)))) + :rest ((let ((var (second ele))) + (lambda-var-dispatch var (sb!di:frame-code-location + *current-frame*) + (error "unused &REST argument before n'th argument") + (dolist (value + (sb!di:debug-var-value var *current-frame*) + (error + "The argument specification ~S is out of range." + n)) + (if (zerop n) + (return-from nth-arg (values value nil)) + (decf n))) + (error "invalid &REST argument before n'th argument"))))) (decf n)))) (defun arg (n) @@ -1020,15 +1309,15 @@ argument") pairs as separate arguments." (multiple-value-bind (var lambda-var-p) (nth-arg n (handler-case (sb!di:debug-fun-lambda-list - (sb!di:frame-debug-fun *current-frame*)) - (sb!di:lambda-list-unavailable () - (error "No argument values are available.")))) + (sb!di:frame-debug-fun *current-frame*)) + (sb!di:lambda-list-unavailable () + (error "No argument values are available.")))) (if lambda-var-p - (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) - (error "Unused arguments have no values.") - (sb!di:debug-var-value var *current-frame*) - (error "invalid argument value")) - var))) + (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*) + (error "Unused arguments have no values.") + (sb!di:debug-var-value var *current-frame*) + (error "invalid argument value")) + var))) ;;;; machinery for definition of debug loop commands @@ -1040,11 +1329,11 @@ argument") (let ((fun-name (symbolicate name "-DEBUG-COMMAND"))) `(progn (setf *debug-commands* - (remove ,name *debug-commands* :key #'car :test #'string=)) + (remove ,name *debug-commands* :key #'car :test #'string=)) (defun ,fun-name ,args - (unless *in-the-debugger* - (error "invoking debugger command while outside the debugger")) - ,@body) + (unless *in-the-debugger* + (error "invoking debugger command while outside the debugger")) + ,@body) (push (cons ,name #',fun-name) *debug-commands*) ',fun-name))) @@ -1064,38 +1353,38 @@ argument") (defun debug-command-p (form &optional other-commands) (if (or (symbolp form) (integerp form)) (let* ((name - (if (symbolp form) - (symbol-name form) - (format nil "~W" form))) - (len (length name)) - (res nil)) - (declare (simple-string name) - (fixnum len) - (list res)) - - ;; Find matching commands, punting if exact match. - (flet ((match-command (ele) - (let* ((str (car ele)) - (str-len (length str))) - (declare (simple-string str) - (fixnum str-len)) - (cond ((< str-len len)) - ((= str-len len) - (when (string= name str :end1 len :end2 len) - (return-from debug-command-p (cdr ele)))) - ((string= name str :end1 len :end2 len) - (push ele res)))))) - (mapc #'match-command *debug-commands*) - (mapc #'match-command other-commands)) - - ;; Return the right value. - (cond ((not res) nil) - ((= (length res) 1) - (cdar res)) - (t ; Just return the names. - (do ((cmds res (cdr cmds))) - ((not cmds) res) - (setf (car cmds) (caar cmds)))))))) + (if (symbolp form) + (symbol-name form) + (format nil "~W" form))) + (len (length name)) + (res nil)) + (declare (simple-string name) + (fixnum len) + (list res)) + + ;; Find matching commands, punting if exact match. + (flet ((match-command (ele) + (let* ((str (car ele)) + (str-len (length str))) + (declare (simple-string str) + (fixnum str-len)) + (cond ((< str-len len)) + ((= str-len len) + (when (string= name str :end1 len :end2 len) + (return-from debug-command-p (cdr ele)))) + ((string= name str :end1 len :end2 len) + (push ele res)))))) + (mapc #'match-command *debug-commands*) + (mapc #'match-command other-commands)) + + ;; Return the right value. + (cond ((not res) nil) + ((= (length res) 1) + (cdar res)) + (t ; Just return the names. + (do ((cmds res (cdr cmds))) + ((not cmds) res) + (setf (car cmds) (caar cmds)))))))) ;;; Return a list of debug commands (in the same format as ;;; *DEBUG-COMMANDS*) that invoke each active restart. @@ -1105,15 +1394,15 @@ argument") ;;; restart of the same name, or it is NIL). (defun make-restart-commands (&optional (restarts *debug-restarts*)) (let ((commands) - (num 0)) ; better be the same as show-restarts! + (num 0)) ; better be the same as show-restarts! (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun (lambda () - (/show0 "in restart-command closure, about to i-r-i") - (invoke-restart-interactively restart)))) + (/show0 "in restart-command closure, about to i-r-i") + (invoke-restart-interactively restart)))) (push (cons (prin1-to-string num) restart-fun) commands) - (unless (or (null (restart-name restart)) + (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) (push (cons name restart-fun) commands)))) (incf num)) @@ -1124,108 +1413,84 @@ argument") (!def-debug-command "UP" () (let ((next (sb!di:frame-up *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next)) - (t - (format t "~&Top of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Top of stack."))))) (!def-debug-command "DOWN" () (let ((next (sb!di:frame-down *current-frame*))) (cond (next - (setf *current-frame* next) - (print-frame-call next)) - (t - (format t "~&Bottom of stack."))))) + (setf *current-frame* next) + (print-frame-call next *debug-io*)) + (t + (format *debug-io* "~&Bottom of stack."))))) (!def-debug-command-alias "D" "DOWN") -;;; CMU CL had this command, but SBCL doesn't, since it's redundant -;;; with "FRAME 0", and it interferes with abbreviations for the -;;; TOPLEVEL restart. -;;;(!def-debug-command "TOP" () -;;; (do ((prev *current-frame* lead) -;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead))) -;;; ((null lead) -;;; (setf *current-frame* prev) -;;; (print-frame-call prev)))) - (!def-debug-command "BOTTOM" () (do ((prev *current-frame* lead) (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") (!def-debug-command "FRAME" (&optional - (n (read-prompting-maybe "frame number: "))) + (n (read-prompting-maybe "frame number: "))) (setf *current-frame* - (multiple-value-bind (next-frame-fun limit-string) - (if (< n (sb!di:frame-number *current-frame*)) - (values #'sb!di:frame-up "top") - (values #'sb!di:frame-down "bottom")) - (do ((frame *current-frame*)) - ((= n (sb!di:frame-number frame)) - frame) - (let ((next-frame (funcall next-frame-fun frame))) - (cond (next-frame - (setf frame next-frame)) - (t - (format t - "The ~A of the stack was encountered.~%" - limit-string) - (return frame))))))) - (print-frame-call *current-frame*)) + (multiple-value-bind (next-frame-fun limit-string) + (if (< n (sb!di:frame-number *current-frame*)) + (values #'sb!di:frame-up "top") + (values #'sb!di:frame-down "bottom")) + (do ((frame *current-frame*)) + ((= n (sb!di:frame-number frame)) + frame) + (let ((next-frame (funcall next-frame-fun frame))) + (cond (next-frame + (setf frame next-frame)) + (t + (format *debug-io* + "The ~A of the stack was encountered.~%" + limit-string) + (return frame))))))) + (print-frame-call *current-frame* *debug-io*)) (!def-debug-command-alias "F" "FRAME") ;;;; commands for entering and leaving the debugger -;;; 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)) +(!def-debug-command "TOPLEVEL" () + (throw '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 "RESTART -;;; CONTINUE", that's OK too). - -;;;(!def-debug-command "GO" () -;;; (continue *debug-condition*) -;;; (error "There is no restart named CONTINUE.")) +;;; make T safe +(!def-debug-command-alias "TOP" "TOPLEVEL") (!def-debug-command "RESTART" () (/show0 "doing RESTART debug-command") (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) - (write-string "restart: ") - (force-output) - (setf num (read *standard-input*))) + (write-string "restart: " *debug-io*) + (force-output *debug-io*) + (setf num (read *debug-io*))) (let ((restart (typecase num - (unsigned-byte - (nth num *debug-restarts*)) - (symbol - (find num *debug-restarts* :key #'restart-name - :test (lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) - (t - (format t "~S is invalid as a restart name.~%" num) - (return-from restart-debug-command nil))))) + (unsigned-byte + (nth num *debug-restarts*)) + (symbol + (find num *debug-restarts* :key #'restart-name + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) + (t + (format *debug-io* "~S is invalid as a restart name.~%" + num) + (return-from restart-debug-command nil))))) (/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."))))) + (invoke-restart-interactively restart) + (princ "There is no such restart." *debug-io*))))) ;;;; information commands @@ -1236,9 +1501,9 @@ argument") ;; desperate holdout is running this on a dumb terminal somewhere, ;; we tell him where to find the message stored as a string. (format *debug-io* - "~&~A~2%(The HELP string is stored in ~S.)~%" - *debug-help-string* - '*debug-help-string*)) + "~&~A~2%(The HELP string is stored in ~S.)~%" + *debug-help-string* + '*debug-help-string*)) (!def-debug-command-alias "?" "HELP") @@ -1247,391 +1512,308 @@ argument") (show-restarts *debug-restarts* *debug-io*)) (!def-debug-command "BACKTRACE" () - (backtrace (read-if-available most-positive-fixnum))) + (print-backtrace :count (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") (!def-debug-command "LIST-LOCALS" () (let ((d-fun (sb!di:frame-debug-fun *current-frame*))) (if (sb!di:debug-var-info-available d-fun) - (let ((*standard-output* *debug-io*) - (location (sb!di:frame-code-location *current-frame*)) - (prefix (read-if-available nil)) - (any-p nil) - (any-valid-p nil)) - (dolist (v (sb!di:ambiguous-debug-vars - d-fun - (if prefix (string prefix) ""))) - (setf any-p t) - (when (eq (sb!di:debug-var-validity v location) :valid) - (setf any-valid-p t) - (format t "~S~:[#~W~;~*~] = ~S~%" - (sb!di:debug-var-symbol v) - (zerop (sb!di:debug-var-id v)) - (sb!di:debug-var-id v) - (sb!di:debug-var-value v *current-frame*)))) - - (cond - ((not any-p) - (format t "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." - prefix)))) - (write-line "There is no variable information available.")))) + (let ((*standard-output* *debug-io*) + (location (sb!di:frame-code-location *current-frame*)) + (prefix (read-if-available nil)) + (any-p nil) + (any-valid-p nil) + (more-context nil) + (more-count nil)) + (dolist (v (sb!di:ambiguous-debug-vars + d-fun + (if prefix (string prefix) ""))) + (setf any-p t) + (when (eq (sb!di:debug-var-validity v location) :valid) + (setf any-valid-p t) + (case (sb!di::debug-var-info v) + (:more-context + (setf more-context (sb!di:debug-var-value v *current-frame*))) + (:more-count + (setf more-count (sb!di:debug-var-value v *current-frame*)))) + (format *debug-io* "~S~:[#~W~;~*~] = ~S~%" + (sb!di:debug-var-symbol v) + (zerop (sb!di:debug-var-id v)) + (sb!di:debug-var-id v) + (sb!di:debug-var-value v *current-frame*)))) + (when (and more-context more-count) + (format *debug-io* "~S = ~S~%" + 'more + (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count)))) + (cond + ((not any-p) + (format *debug-io* + "There are no local variables ~@[starting with ~A ~]~ + in the function." + prefix)) + ((not any-valid-p) + (format *debug-io* + "All variables ~@[starting with ~A ~]currently ~ + have invalid values." + prefix)))) + (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 -;;; 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 -;;; a debug session and the change doesn't show up. And removing this -;;; would simplify the system, which I like. -- WHN 19990903 -(defvar *cached-debug-source* nil) -(declaim (type (or sb!di:debug-source null) *cached-debug-source*)) -(defvar *cached-source-stream* nil) -(declaim (type (or stream null) *cached-source-stream*)) - -;;; To suppress the read-time evaluation #. macro during source read, -;;; *READTABLE* is modified. *READTABLE* is cached to avoid -;;; copying it each time, and invalidated when the -;;; *CACHED-DEBUG-SOURCE* has changed. -(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*) - -;;; 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-toplevel-form (location) - (let ((d-source (sb!di:code-location-debug-source location))) - (if (and (eq d-source *cached-debug-source*) - (eql (sb!di:code-location-toplevel-form-offset location) - *cached-toplevel-form-offset*)) - (values *cached-form-number-translations* *cached-toplevel-form*) - (let* ((offset (sb!di:code-location-toplevel-form-offset location)) - (res - (ecase (sb!di:debug-source-from d-source) - (:file (get-file-toplevel-form location)) - (:lisp (svref (sb!di:debug-source-name d-source) offset))))) - (setq *cached-toplevel-form-offset* offset) - (values (setq *cached-form-number-translations* - (sb!di:form-number-translations res offset)) - (setq *cached-toplevel-form* res)))))) - -;;; Locate the source file (if it still exists) and grab the top level -;;; form. If the file is modified, we use the top level form offset -;;; instead of the recorded character offset. -(defun get-file-toplevel-form (location) - (let* ((d-source (sb!di:code-location-debug-source location)) - (tlf-offset (sb!di:code-location-toplevel-form-offset location)) - (local-tlf-offset (- tlf-offset - (sb!di:debug-source-root-number d-source))) - (char-offset - (aref (or (sb!di:debug-source-start-positions d-source) - (error "no start positions map")) - local-tlf-offset)) - (name (sb!di:debug-source-name d-source))) - (unless (eq d-source *cached-debug-source*) - (unless (and *cached-source-stream* - (equal (pathname *cached-source-stream*) - (pathname name))) - (setq *cached-readtable* nil) - (when *cached-source-stream* (close *cached-source-stream*)) - (setq *cached-source-stream* (open name :if-does-not-exist nil)) - (unless *cached-source-stream* - (error "The source file no longer exists:~% ~A" (namestring name))) - (format t "~%; file: ~A~%" (namestring name))) - - (setq *cached-debug-source* - (if (= (sb!di:debug-source-created d-source) - (file-write-date name)) - d-source nil))) - - (cond - ((eq *cached-debug-source* d-source) - (file-position *cached-source-stream* char-offset)) - (t - (format t "~%; 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)) - (dotimes (i local-tlf-offset) - (read *cached-source-stream*))))) - (unless *cached-readtable* - (setq *cached-readtable* (copy-readtable)) - (set-dispatch-macro-character - #\# #\. - (lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token))) - *cached-readtable*)) - (let ((*readtable* *cached-readtable*)) - (read *cached-source-stream*)))) - -(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-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 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.")) - (t - (dolist (ele *breakpoints*) - (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele))) - (setf *breakpoints* nil) - (format t "all breakpoints deleted~%"))))) - -(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT") +;;; Stuff to clean up before saving a core +(defun debug-deinit () + ;; Nothing to do right now. Once there was, maybe once there + ;; will be again. + ) + +(defun code-location-source-form (location context &optional (errorp t)) + (let* ((start-location (maybe-block-start-location location)) + (form-num (sb!di:code-location-form-number start-location))) + (multiple-value-bind (translations form) + (sb!di:get-toplevel-form start-location) + (cond ((< form-num (length translations)) + (sb!di:source-path-context form + (svref translations form-num) + context)) + (t + (funcall (if errorp #'error #'warn) + "~@")))))) + +;;; start single-stepping +(!def-debug-command "START" () + (if (typep *debug-condition* 'step-condition) + (format *debug-io* "~&Already single-stepping.~%") + (let ((restart (find-restart 'continue *debug-condition*))) + (cond (restart + (sb!impl::enable-stepping) + (invoke-restart restart)) + (t + (format *debug-io* "~&Non-continuable error, cannot start stepping.~%")))))) + +(defmacro def-step-command (command-name restart-name) + `(!def-debug-command ,command-name () + (if (typep *debug-condition* 'step-condition) + (let ((restart (find-restart ',restart-name *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))) + +(def-step-command "STEP" step-into) +(def-step-command "NEXT" step-next) +(def-step-command "STOP" step-continue) + +(!def-debug-command-alias "S" "STEP") +(!def-debug-command-alias "N" "NEXT") + +(!def-debug-command "OUT" () + (if (typep *debug-condition* 'step-condition) + (if sb!impl::*step-out* + (let ((restart (find-restart 'step-out *debug-condition*))) + (aver restart) + (invoke-restart restart)) + (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%")) + (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))) + ;;; miscellaneous commands (!def-debug-command "DESCRIBE" () (let* ((curloc (sb!di:frame-code-location *current-frame*)) - (debug-fun (sb!di:code-location-debug-fun curloc)) - (function (sb!di:debug-fun-fun debug-fun))) + (debug-fun (sb!di:code-location-debug-fun curloc)) + (function (sb!di:debug-fun-fun debug-fun))) (if function - (describe function) - (format t "can't figure out the function for this frame")))) + (describe function) + (format *debug-io* "can't figure out the function for this frame")))) + +(!def-debug-command "SLURP" () + (loop while (read-char-no-hang *standard-input*))) + +;;; RETURN-FROM-FRAME and RESTART-FRAME + +(defun unwind-to-frame-and-call (frame thunk) + #!+unwind-to-frame-and-call-vop + (flet ((sap-int/fixnum (sap) + ;; On unithreaded X86 *BINDING-STACK-POINTER* and + ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through + ;; some hoops to make these calculated values negative too. + (ash (truly-the (signed-byte #.sb!vm:n-word-bits) + (sap-int sap)) + (- sb!vm::n-fixnum-tag-bits)))) + ;; To properly unwind the stack, we need three pieces of information: + ;; * The unwind block that should be active after the unwind + ;; * The catch block that should be active after the unwind + ;; * The values that the binding stack pointer should have after the + ;; unwind. + (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame))) + (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame)))) + ;; This VOP will run the neccessary cleanup forms, reset the fp, and + ;; then call the supplied function. + (sb!vm::%primitive sb!vm::unwind-to-frame-and-call + (sb!di::frame-pointer frame) + (find-enclosing-uwp frame) + (lambda () + ;; Before calling the user-specified + ;; function, we need to restore the binding + ;; stack and the catch block. The unwind block + ;; is taken care of by the VOP. + (sb!vm::%primitive sb!vm::unbind-to-here + unbind-to) + (setf sb!vm::*current-catch-block* block) + (funcall thunk))))) + #!-unwind-to-frame-and-call-vop + (let ((tag (gensym))) + (sb!di:replace-frame-catch-tag frame + 'sb!c:debug-catch-tag + tag) + (throw tag thunk))) + +(defun find-binding-stack-pointer (frame) + #!-stack-grows-downward-not-upward + (declare (ignore frame)) + #!-stack-grows-downward-not-upward + (error "Not implemented on this architecture") + #!+stack-grows-downward-not-upward + (let ((bsp (sb!vm::binding-stack-pointer-sap)) + (unbind-to nil) + (fp (sb!di::frame-pointer frame)) + (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm:*binding-stack-start* + sb!vm:n-fixnum-tag-bits))))) + ;; Walk the binding stack looking for an entry where the symbol is + ;; an unbound-symbol marker and the value is equal to the frame + ;; pointer. These entries are inserted into the stack by the + ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into + ;; the function during IR2). If an entry wasn't found, the + ;; function that the frame corresponds to wasn't compiled with a + ;; high enough debug setting, and can't be restarted / returned + ;; from. + (loop until (sap= bsp start) + do (progn + (setf bsp (sap+ bsp + (- (* sb!vm:binding-size sb!vm:n-word-bytes)))) + (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot + sb!vm:n-word-bytes))) + (value (sap-ref-sap bsp (* sb!vm:binding-value-slot + sb!vm:n-word-bytes)))) + (when (eql symbol sb!vm:unbound-marker-widetag) + (when (sap= value fp) + (setf unbind-to bsp)))))) + unbind-to)) + +(defun find-enclosing-catch-block (frame) + ;; Walk the catch block chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-catch-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-block (loop for block = current-block + then (sap-ref-sap block + (* sb!vm:catch-block-previous-catch-slot + sb!vm::n-word-bytes)) + when (or (zerop (sap-int block)) + (sap> block frame-pointer)) + return block))) + enclosing-block)) + +(defun find-enclosing-uwp (frame) + ;; Walk the UWP chain looking for the first entry with an address + ;; higher than the pointer for FRAME or a null pointer. + (let* ((frame-pointer (sb!di::frame-pointer frame)) + (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0) + (ash sb!vm::*current-unwind-protect-block* + sb!vm:n-fixnum-tag-bits)))) + (enclosing-uwp (loop for uwp-block = current-uwp + then (sap-ref-sap uwp-block + sb!vm:unwind-block-current-uwp-slot) + when (or (zerop (sap-int uwp-block)) + (sap> uwp-block frame-pointer)) + return uwp-block))) + enclosing-uwp)) + +(!def-debug-command "RETURN" (&optional + (return (read-prompting-maybe + "return: "))) + (if (frame-has-debug-tag-p *current-frame*) + (let* ((code-location (sb!di:frame-code-location *current-frame*)) + (values (multiple-value-list + (funcall (sb!di:preprocess-for-eval return code-location) + *current-frame*)))) + (unwind-to-frame-and-call *current-frame* (lambda () + (values-list values)))) + (format *debug-io* + "~@"))) + +(!def-debug-command "RESTART-FRAME" () + (if (frame-has-debug-tag-p *current-frame*) + (multiple-value-bind (fname args) (frame-call *current-frame*) + (multiple-value-bind (fun arglist ok) + (if (and (legal-fun-name-p fname) (fboundp fname)) + (values (fdefinition fname) args t) + (values (sb!di:debug-fun-fun (sb!di:frame-debug-fun *current-frame*)) + (frame-args-as-list *current-frame*) + nil)) + (when (and fun + (or ok + (y-or-n-p "~@"))) + (unwind-to-frame-and-call *current-frame* + (lambda () + ;; Ensure TCO. + (declare (optimize (debug 0))) + (apply fun arglist)))) + (format *debug-io* + "Can't restart ~S: no function for frame." + *current-frame*))) + (format *debug-io* + "~@" + *current-frame*))) + +(defun frame-has-debug-tag-p (frame) + #!+unwind-to-frame-and-call-vop + (not (null (find-binding-stack-pointer frame))) + #!-unwind-to-frame-and-call-vop + (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car)) + +(defun frame-has-debug-vars-p (frame) + (sb!di:debug-var-info-available + (sb!di:code-location-debug-fun + (sb!di:frame-code-location frame)))) + +;; Hack: ensure that *U-T-F-F* has a tls index. +#!+unwind-to-frame-and-call-vop +(let ((sb!vm::*unwind-to-frame-function* (lambda ())))) + ;;;; 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 *debug-io*) + (force-output *debug-io*)) + (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))