\f
;;;; variables and constants
-(defvar *debug-print-level* 3
+;;; things to consider when tweaking these values:
+;;; * We're afraid to just default them to NIL and NIL, in case the
+;;; user inadvertently causes a hairy data structure to be printed
+;;; when he inadvertently enters the debugger.
+;;; * We don't want to truncate output too much. These days anyone
+;;; can easily run their Lisp in a windowing system or under Emacs,
+;;; so it's not the end of the world even if the worst case is a
+;;; few thousand lines of output.
+;;; * As condition :REPORT methods are converted to use the pretty
+;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
+;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
+;;; ARG-COUNT-ERROR printed as
+;;; error while parsing arguments to DESTRUCTURING-BIND:
+;;; invalid number of elements in
+;;; #
+;;; to satisfy lambda list
+;;; #:
+;;; exactly 2 expected, but 5 found
+(defvar *debug-print-variable-alist* nil
#!+sb-doc
- "*PRINT-LEVEL* for the debugger")
+ "an association list describing new bindings for special variables
+to be used within the debugger. Eg.
-(defvar *debug-print-length* 5
- #!+sb-doc
- "*PRINT-LENGTH* for the debugger")
+ ((*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,
;;; 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)
"Should the debugger display beginner-oriented help messages?")
(defun debug-prompt (stream)
-
- ;; old behavior, will probably go away in sbcl-0.7.x
- (format stream "~%~D" (sb!di:frame-number *current-frame*))
- (dotimes (i *debug-command-level*)
- (write-char #\] stream))
- (write-char #\space stream)
-
- ;; planned new behavior, delayed since it will break ILISP
- #+nil
+ (sb!thread::get-foreground)
(format stream
- "~%~D~:[~;[~D~]] "
- (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.")
+ 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.)")
\f
-;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
-(define-condition step-condition (simple-condition) ())
-\f
-;;;; breakpoint state
-
-(defvar *only-block-start-locations* nil
- #!+sb-doc
- "When true, the LIST-LOCATIONS command only displays block start locations.
- Otherwise, all locations are displayed.")
-
-(defvar *print-location-kind* nil
- #!+sb-doc
- "When true, list the code location type in the LIST-LOCATIONS command.")
-
-;;; a list of the types of code-locations that should not be stepped
-;;; to and should not be listed when listing breakpoints
-(defvar *bad-code-location-types* '(:call-site :internal-error))
-(declaim (type list *bad-code-location-types*))
-
-;;; code locations of the possible breakpoints
-(defvar *possible-breakpoints*)
-(declaim (type list *possible-breakpoints*))
-
-;;; a list of the made and active breakpoints, each is a
-;;; BREAKPOINT-INFO structure
-(defvar *breakpoints* nil)
-(declaim (type list *breakpoints*))
-
-;;; a list of BREAKPOINT-INFO structures of the made and active step
-;;; breakpoints
-(defvar *step-breakpoints* nil)
-(declaim (type list *step-breakpoints*))
-
-;;; the number of times left to step
-(defvar *number-of-steps* 1)
-(declaim (type integer *number-of-steps*))
-
-;;; This is used when listing and setting breakpoints.
-(defvar *default-breakpoint-debug-function* nil)
-(declaim (type (or list sb!di:debug-function) *default-breakpoint-debug-function*))
-\f
-;;;; code location utilities
-
-;;; Return the first code-location in the passed debug block.
-(defun first-code-location (debug-block)
- (let ((found nil)
- (first-code-location nil))
- (sb!di:do-debug-block-locations (code-location debug-block)
- (unless found
- (setf first-code-location code-location)
- (setf found t)))
- first-code-location))
-
-;;; Return a list of the next code-locations following the one passed.
-;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned.
-(defun next-code-locations (code-location)
- (let ((debug-block (sb!di:code-location-debug-block code-location))
- (block-code-locations nil))
- (sb!di:do-debug-block-locations (block-code-location debug-block)
- (unless (member (sb!di:code-location-kind block-code-location)
- *bad-code-location-types*)
- (push block-code-location block-code-locations)))
- (setf block-code-locations (nreverse block-code-locations))
- (let* ((code-loc-list (rest (member code-location block-code-locations
- :test #'sb!di:code-location=)))
- (next-list (cond (code-loc-list
- (list (first code-loc-list)))
- ((map 'list #'first-code-location
- (sb!di:debug-block-successors debug-block)))
- (t nil))))
- (when (and (= (length next-list) 1)
- (sb!di:code-location= (first next-list) code-location))
- (setf next-list (next-code-locations (first next-list))))
- next-list)))
-
-;;; Returns a list of code-locations of the possible breakpoints of the
-;;; debug-function passed.
-(defun possible-breakpoints (debug-function)
- (let ((possible-breakpoints nil))
- (sb!di:do-debug-function-blocks (debug-block debug-function)
- (unless (sb!di:debug-block-elsewhere-p debug-block)
- (if *only-block-start-locations*
- (push (first-code-location debug-block) possible-breakpoints)
- (sb!di:do-debug-block-locations (code-location debug-block)
- (when (not (member (sb!di:code-location-kind code-location)
- *bad-code-location-types*))
- (push code-location possible-breakpoints))))))
- (nreverse possible-breakpoints)))
-
-;;; Searches the info-list for the item passed (code-location,
-;;; debug-function, or breakpoint-info). If the item passed is a debug
-;;; function then kind will be compared if it was specified. The kind
-;;; if also compared if a breakpoint-info is passed since it's in the
-;;; breakpoint. The info structure is returned if found.
-(defun location-in-list (place info-list &optional (kind nil))
- (when (breakpoint-info-p place)
- (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
- (setf place (breakpoint-info-place place)))
- (cond ((sb!di:code-location-p place)
- (find place info-list
- :key #'breakpoint-info-place
- :test #'(lambda (x y) (and (sb!di:code-location-p y)
- (sb!di:code-location= x y)))))
- (t
- (find place info-list
- :test #'(lambda (x-debug-function y-info)
- (let ((y-place (breakpoint-info-place y-info))
- (y-breakpoint (breakpoint-info-breakpoint
- y-info)))
- (and (sb!di:debug-function-p y-place)
- (eq x-debug-function y-place)
- (or (not kind)
- (eq kind (sb!di:breakpoint-kind
- y-breakpoint))))))))))
+(defmacro with-debug-io-syntax (() &body body)
+ (let ((thunk (gensym "THUNK")))
+ `(dx-flet ((,thunk ()
+ ,@body))
+ (funcall-with-debug-io-syntax #',thunk))))
;;; If LOC is an unknown location, then try to find the block start
;;; location. Used by source printing to some information instead of
(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))
\f
-;;;; the BREAKPOINT-INFO structure
-
-;;; info about a made breakpoint
-(defstruct (breakpoint-info (:copier nil))
- ;; where we are going to stop
- (place (required-argument)
- :type (or sb!di:code-location sb!di:debug-function))
- ;; the breakpoint returned by sb!di:make-breakpoint
- (breakpoint (required-argument) :type sb!di:breakpoint)
- ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
- ;; non-NIL, drop into the debugger.
- (break #'identity :type function)
- ;; the function returned from sb!di:preprocess-for-eval. If result is
- ;; non-NIL, eval (each) print and print results.
- (condition #'identity :type function)
- ;; the list of functions from sb!di:preprocess-for-eval to evaluate.
- ;; Results are conditionally printed. Car of each element is the
- ;; function, cdr is the form it goes with.
- (print nil :type list)
- ;; the number used when listing the possible breakpoints within a
- ;; function. Could also be a symbol such as start or end.
- (code-location-number (required-argument) :type (or symbol integer))
- ;; the number used when listing the breakpoints active and to delete
- ;; breakpoints
- (breakpoint-number (required-argument) :type integer))
-
-;;; Return a new BREAKPOINT-INFO structure with the info passed.
-(defun create-breakpoint-info (place breakpoint code-location-number
- &key (break #'identity)
- (condition #'identity) (print nil))
- (setf *breakpoints*
- (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
- (let ((breakpoint-number
- (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
- ((or (> i (length *breakpoints*))
- (not (= i (breakpoint-info-breakpoint-number
- (first breakpoints)))))
-
- i))))
- (make-breakpoint-info :place place :breakpoint breakpoint
- :code-location-number code-location-number
- :breakpoint-number breakpoint-number
- :break break :condition condition :print print)))
-
-;;; Print the breakpoint info for the breakpoint-info structure passed.
-(defun print-breakpoint-info (breakpoint-info)
- (let ((place (breakpoint-info-place breakpoint-info))
- (bp-number (breakpoint-info-breakpoint-number breakpoint-info))
- (loc-number (breakpoint-info-code-location-number breakpoint-info)))
- (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
- (:code-location
- (print-code-location-source-form place 0)
- (format t
- "~&~S: ~S in ~S"
- bp-number
- loc-number
- (sb!di:debug-function-name (sb!di:code-location-debug-function
- place))))
- (:function-start
- (format t "~&~S: FUNCTION-START in ~S" bp-number
- (sb!di:debug-function-name place)))
- (:function-end
- (format t "~&~S: FUNCTION-END in ~S" bp-number
- (sb!di:debug-function-name place))))))
-\f
-;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
-
-;;; This must be passed as the hook function. It keeps track of where
-;;; STEP breakpoints are.
-(defun main-hook-function (current-frame breakpoint &optional return-vals
- function-end-cookie)
- (setf *default-breakpoint-debug-function*
- (sb!di:frame-debug-function current-frame))
- (dolist (step-info *step-breakpoints*)
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info))
- (let ((bp-info (location-in-list step-info *breakpoints*)))
- (when bp-info
- (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
- (let ((*stack-top-hint* current-frame)
- (step-hit-info
- (location-in-list (sb!di:breakpoint-what breakpoint)
- *step-breakpoints*
- (sb!di:breakpoint-kind breakpoint)))
- (bp-hit-info
- (location-in-list (sb!di:breakpoint-what breakpoint)
- *breakpoints*
- (sb!di:breakpoint-kind breakpoint)))
- (break)
- (condition)
- (string ""))
- (setf *step-breakpoints* nil)
- (labels ((build-string (str)
- (setf string (concatenate 'string string str)))
- (print-common-info ()
- (build-string
- (with-output-to-string (*standard-output*)
- (when function-end-cookie
- (format t "~%Return values: ~S" return-vals))
- (when condition
- (when (breakpoint-info-print bp-hit-info)
- (format t "~%")
- (print-frame-call current-frame))
- (dolist (print (breakpoint-info-print bp-hit-info))
- (format t "~& ~S = ~S" (rest print)
- (funcall (first print) current-frame))))))))
- (when bp-hit-info
- (setf break (funcall (breakpoint-info-break bp-hit-info)
- current-frame))
- (setf condition (funcall (breakpoint-info-condition bp-hit-info)
- current-frame)))
- (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
- (build-string (format nil "~&*Step (to a breakpoint)*"))
- (print-common-info)
- (break string))
- ((and bp-hit-info step-hit-info break)
- (build-string (format nil "~&*Step (to a breakpoint)*"))
- (print-common-info)
- (break string))
- ((and bp-hit-info step-hit-info)
- (print-common-info)
- (format t "~A" string)
- (decf *number-of-steps*)
- (set-step-breakpoint current-frame))
- ((and step-hit-info (= 1 *number-of-steps*))
- (build-string "*Step*")
- (break (make-condition 'step-condition :format-control string)))
- (step-hit-info
- (decf *number-of-steps*)
- (set-step-breakpoint current-frame))
- (bp-hit-info
- (when break
- (build-string (format nil "~&*Breakpoint hit*")))
- (print-common-info)
- (if break
- (break string)
- (format t "~A" string)))
- (t
- (break "error in main-hook-function: unknown breakpoint"))))))
-\f
-;;; Set breakpoints at the next possible code-locations. After calling
-;;; this, either (CONTINUE) if in the debugger or just let program flow
-;;; return if in a hook function.
-(defun set-step-breakpoint (frame)
- (cond
- ((sb!di:debug-block-elsewhere-p (sb!di:code-location-debug-block
- (sb!di:frame-code-location frame)))
- ;; FIXME: FORMAT T is used for error output here and elsewhere in
- ;; the debug code.
- (format t "cannot step, in elsewhere code~%"))
- (t
- (let* ((code-location (sb!di:frame-code-location frame))
- (next-code-locations (next-code-locations code-location)))
- (cond
- (next-code-locations
- (dolist (code-location next-code-locations)
- (let ((bp-info (location-in-list code-location *breakpoints*)))
- (when bp-info
- (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
- bp-info))))
- (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location
- :kind :code-location)))
- (sb!di:activate-breakpoint bp)
- (push (create-breakpoint-info code-location bp 0)
- *step-breakpoints*))))
- (t
- (let* ((debug-function (sb!di:frame-debug-function *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-function debug-function
- :kind :function-end)))
- (sb!di:activate-breakpoint bp)
- (push (create-breakpoint-info debug-function bp 0)
- *step-breakpoints*))))))))
-\f
-;;;; 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))
-\f
;;;; 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
+
+ (<gf-name> ...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 <gf-name> [<qualifier>*] (<specializer>*)) ...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 <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
+
+ or
+
+ ((sb-pcl:slow-method <gf-name> [<qualifier>*] (<specializer>*)) ...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
+ "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 occurred, 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
- "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*)
- (values))
+ "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."
+ (with-debug-io-syntax ()
+ (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:
+
+ \(<name> ...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 #<unavailable argument>. 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))))
\f
;;;; frame printing
;;; 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)))
(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 :type t)
- (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* ((d-fun (sb!di:frame-debug-function frame))
- (loc (sb!di:frame-code-location frame))
- (results (list (sb!di:debug-function-name d-fun))))
- (handler-case
- (dolist (ele (sb!di:debug-function-lambda-list d-fun))
- (lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) results))
- :optional ((push (frame-call-arg (second ele) loc frame) results))
- :keyword ((push (second ele) results)
- (push (frame-call-arg (third ele) loc frame) results))
- :deleted ((push (frame-call-arg ele loc frame) results))
- :rest ((lambda-var-dispatch (second ele) loc
- nil
- (progn
- (setf results
- (append (reverse (sb!di:debug-var-value
- (second ele) frame))
- results))
- (return))
- (push (make-unprintable-object
- "unavailable &REST argument")
- results)))))
- (sb!di:lambda-list-unavailable
- ()
- (push (make-unprintable-object "lambda list unavailable") results)))
- (pprint-logical-block (*standard-output* nil)
- (let ((x (nreverse (mapcar #'ensure-printable-object results))))
- (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))
- (when (sb!di:debug-function-kind d-fun)
- (write-char #\[)
- (prin1 (sb!di:debug-function-kind d-fun))
- (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 interrupted-frame-error (frame)
+ (when (and (sb!di::compiled-frame-p frame)
+ (sb!di::compiled-frame-escaped frame))
+ (let ((error-number (sb!vm:internal-error-args
+ (sb!di::compiled-frame-escaped frame))))
+ (when (array-in-bounds-p sb!c:*backend-internal-errors* error-number)
+ (car (svref sb!c:*backend-internal-errors* error-number))))))
+
+(defun clean-xep (frame name args info)
+ (values (second name)
+ (if (consp args)
+ (let* ((count (first args))
+ (real-args (rest args)))
+ (if (and (integerp count)
+ (eq (interrupted-frame-error frame)
+ 'invalid-arg-count-error))
+ ;; 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 (frame name method-frame-style info)
+ (let ((args (frame-args-as-list frame)))
+ (if (consp name)
+ (case (first name)
+ ((sb!c::xep sb!c::tl-xep)
+ (clean-xep frame name args info))
+ ((sb!c::&more-processor)
+ (clean-&more-processor name args info))
+ ((sb!c::&optional-processor)
+ (clean-frame-call frame (second name) 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
+#<unavailable argument>.
+
+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 frame
+ (sb!di:debug-fun-name debug-fun)
+ 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"))))
;;; Prints a representation of the function call causing FRAME to
;;; exist. VERBOSITY indicates the level of information to output;
-;;; zero indicates just printing the debug-function's name, and one
+;;; 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))))))
\f
;;;; INVOKE-DEBUGGER
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))))
- (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
-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*.
- ;; 2. It isn't customizable.
- ;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
- ;; to the same value as the toplevel default.
- ;; 4. It sets *PACKAGE* to COMMON-LISP-USER, which is not
- ;; helpful behavior for a debugger.
- ;; We try to remedy all these problems with explicit
- ;; rebindings here.
- (sb!kernel:*current-level* 0)
- (*print-length* *debug-print-length*)
- (*print-level* *debug-print-level*)
- (*readtable* *debug-readtable*)
- (*print-readably* nil)
- (*print-pretty* t)
- (*package* original-package))
-
- ;; 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&~@<debugger invoked on condition of type ~S: ~
- ~2I~_~A~:>~%"
- (type-of *debug-condition*)
- *debug-condition*)
- (error (condition)
- (format *error-output*
- "~&(caught ~S trying to print ~S when entering debugger)~%"
- (type-of condition)
- '*debug-condition*)))
-
- ;; After the initial error/condition/whatever announcement to
- ;; *ERROR-OUTPUT*, we become interactive, and should talk on
- ;; *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*
- "~%~@<Within the debugger, you can type HELP for help. ~
- At any command prompt (within the debugger or not) you ~
- can type (SB-EXT:QUIT) to terminate the SBCL ~
- executable. The condition which caused the debugger to ~
- be entered is bound to ~S. You can suppress this ~
- message by clearing ~S.~:@>~2%"
- '*debug-condition*
- '*debug-beginner-help-p*))
- (show-restarts *debug-restarts* *debug-io*))
- (internal-debug))))))
+
+ (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*))
+
+ ;; 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 *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*
+ "~%~@<Type HELP for debugger help, or ~
+ (SB-EXT:EXIT) to exit from SBCL.~:@>~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 previous-hook)
+ (declare (ignore previous-hook))
+ ;; There is no one there to interact with, so report the
+ ;; condition and terminate the program.
+ (let ((*suppress-print-errors* t)
+ (condition-error-message
+ #.(format nil "A nested error within --disable-debugger error ~
+ handling prevents displaying the original error. Attempting ~
+ to print a backtrace."))
+ (backtrace-error-message
+ #.(format nil "A nested error within --disable-debugger error ~
+ handling prevents printing the backtrace. Sorry, exiting.")))
+ (labels
+ ((failure-quit (&key abort)
+ (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
+ (exit :code 1 :abort abort))
+ (display-condition ()
+ (handler-case
+ (handler-case
+ (print-condition)
+ (condition ()
+ ;; printing failed, try to describe it
+ (describe-condition)))
+ (condition ()
+ ;; ok, give up trying to display the error and inform the user about it
+ (finish-output *error-output*)
+ (%primitive print condition-error-message))))
+ (print-condition ()
+ (format *error-output*
+ "~&~@<Unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil
+ condition)
+ (finish-output *error-output*))
+ (describe-condition ()
+ (format *error-output*
+ "~&Unhandled ~S~@[ in thread ~S~]:~%"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil)
+ (describe condition *error-output*)
+ (finish-output *error-output*))
+ (display-backtrace ()
+ (handler-case
+ (print-backtrace :stream *error-output*
+ :from :interrupted-frame
+ :print-thread t)
+ (condition ()
+ (values)))
+ (finish-output *error-output*)))
+ ;; 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. Separate the error handling of the
+ ;; two phases to maximize the chance of emitting some useful
+ ;; information.
+ (handler-case
+ (progn
+ (display-condition)
+ (display-backtrace)
+ (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 backtrace-error-message))
+ (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)
- (when restarts
- (format s "~&restarts:~%")
- (let ((count 0)
- (names-used '(nil))
- (max-name-len 0))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (when name
- (let ((len (length (princ-to-string name))))
- (when (> len max-name-len)
- (setf max-name-len len))))))
- (unless (zerop max-name-len)
- (incf max-name-len 3))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (cond ((member name names-used)
- (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
- (t
- (format s "~& ~2D: [~VA] ~A~%"
- count (- max-name-len 3) name restart)
- (push name names-used))))
- (incf count)))))
+ (cond ((null restarts)
+ (format s
+ "~&(no restarts: If you didn't do this on purpose, ~
+ please report it as a bug.)~%"))
+ (t
+ (format s "~&restarts (invokable by number or by ~
+ possibly-abbreviated name):~%")
+ (let ((count 0)
+ (names-used '(nil))
+ (max-name-len 0))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (when name
+ (let ((len (length (princ-to-string name))))
+ (when (> len max-name-len)
+ (setf max-name-len len))))))
+ (unless (zerop max-name-len)
+ (incf max-name-len 3))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ ;; 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
;;; 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*))))
\f
;;;; DEBUG-LOOP
"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*))
- (handler-bind ((sb!di:debug-condition (lambda (condition)
- (princ condition *debug-io*)
- (throw 'debug-loop-catcher nil))))
- (fresh-line)
- (print-frame-call *current-frame* :verbosity 2)
+ (*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))))
+ (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*)
- (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 ~D)."
- level)
- (debug-prompt *debug-io*)
- (force-output *debug-io*)
- (let ((input (sb!int:get-stream-command *debug-io*)))
- (cond (input
- (let ((cmd-fun (debug-command-p
- (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
+ "~@<Reduce debugger level (to debug level ~W).~@:>"
+ 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*))
\f
;;;; debug loop functions
(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
`(let* ((temp (etypecase name
- (symbol (sb!di:debug-function-symbol-variables
- (sb!di:frame-debug-function *current-frame*)
- name))
- (simple-string (sb!di:ambiguous-debug-vars
- (sb!di:frame-debug-function *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, ~D: 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
(define-var-operation :set value))
;;; This returns the COUNT'th arg as the user sees it from args, the
-;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a
+;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
;;; potential DEBUG-VAR from the lambda-list, then the second value is
;;; T. If this returns a keyword symbol or a value from a rest arg,
;;; then the second value is NIL.
+;;;
+;;; FIXME: There's probably some way to merge the code here with
+;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
+;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)
(declaim (ftype (function (index list)) nth-arg))
(defun nth-arg (count args)
(let ((n count))
(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)
#!+sb-doc
- "Returns the N'th argument's value if possible. Argument zero is the first
+ "Return the N'th argument's value if possible. Argument zero is the first
argument in a frame's default printed representation. Count keyword/value
pairs as separate arguments."
(multiple-value-bind (var lambda-var-p)
- (nth-arg n (handler-case (sb!di:debug-function-lambda-list
- (sb!di:frame-debug-function *current-frame*))
- (sb!di:lambda-list-unavailable ()
- (error "No argument values are available."))))
+ (nth-arg n (handler-case (sb!di:debug-fun-lambda-list
+ (sb!di:frame-debug-fun *current-frame*))
+ (sb!di:lambda-list-unavailable ()
+ (error "No argument values are available."))))
(if lambda-var-p
- (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)))
\f
;;;; machinery for definition of debug loop commands
(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)))
(defun debug-command-p (form &optional other-commands)
(if (or (symbolp form) (integerp form))
(let* ((name
- (if (symbolp form)
- (symbol-name form)
- (format nil "~D" form)))
- (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.
+;;; *DEBUG-COMMANDS*) that invoke each active restart.
;;;
;;; Two commands are made for each restart: one for the number, and
;;; one for the restart name (unless it's been shadowed by an earlier
;;; restart of the same name, 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 () (invoke-restart-interactively restart))))
- (push (cons (format nil "~d" num) restart-fun) commands)
- (unless (or (null (restart-name restart))
+ (lambda ()
+ (/show0 "in restart-command closure, about to i-r-i")
+ (invoke-restart-interactively restart))))
+ (push (cons (prin1-to-string num) restart-fun) commands)
+ (unless (or (null (restart-name restart))
(find name commands :key #'car :test #'string=))
(push (cons name restart-fun) commands))))
(incf num))
(!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")
\f
;;;; 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::top-level-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 "TOPLEVEL" ()
+ (throw 'toplevel-catcher nil))
-;;;(!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*)))))
\f
;;;; information commands
;; 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")
(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-function *current-frame*)))
+ (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~:[#~D~;~*~] = ~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*))
\f
;;;; 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 top-level form that we printed a source for
-;;; so that we don't have to do repeated reads and calls to
-;;; FORM-NUMBER-TRANSLATIONS.
-(defvar *cached-top-level-form-offset* nil)
-(declaim (type (or index null) *cached-top-level-form-offset*))
-(defvar *cached-top-level-form*)
-(defvar *cached-form-number-translations*)
-
-;;; Given a code location, return the associated form-number
-;;; translations and the actual top-level form. We check our cache ---
-;;; if there is a miss, we dispatch on the kind of the debug source.
-(defun get-top-level-form (location)
- (let ((d-source (sb!di:code-location-debug-source location)))
- (if (and (eq d-source *cached-debug-source*)
- (eql (sb!di:code-location-top-level-form-offset location)
- *cached-top-level-form-offset*))
- (values *cached-form-number-translations* *cached-top-level-form*)
- (let* ((offset (sb!di:code-location-top-level-form-offset location))
- (res
- (ecase (sb!di:debug-source-from d-source)
- (:file (get-file-top-level-form location))
- (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
- (setq *cached-top-level-form-offset* offset)
- (values (setq *cached-form-number-translations*
- (sb!di:form-number-translations res offset))
- (setq *cached-top-level-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-top-level-form (location)
- (let* ((d-source (sb!di:code-location-debug-source location))
- (tlf-offset (sb!di:code-location-top-level-form-offset location))
- (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-top-level-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)))))
-\f
-;;; 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-function*)))
- (cond ((consp df)
- (setf df (sb!di:function-debug-function (eval df)))
- (setf *default-breakpoint-debug-function* df))
- ((or (eq ':c df)
- (not *default-breakpoint-debug-function*))
- (setf df (sb!di:frame-debug-function *current-frame*))
- (setf *default-breakpoint-debug-function* df)))
- (setf *possible-breakpoints* (possible-breakpoints df)))
- (let ((continue-at (sb!di:frame-code-location *current-frame*)))
- (let ((active (location-in-list *default-breakpoint-debug-function*
- *breakpoints* :function-start))
- (here (sb!di:code-location=
- (sb!di:debug-function-start-location
- *default-breakpoint-debug-function*) continue-at)))
- (when (or active here)
- (format t "::FUNCTION-START ")
- (when active (format t " *Active*"))
- (when here (format t " *Continue here*"))))
-
- (let ((prev-location nil)
- (prev-num 0)
- (this-num 0))
- (flet ((flush ()
- (when prev-location
- (let ((this-num (1- this-num)))
- (if (= prev-num this-num)
- (format t "~&~D: " prev-num)
- (format t "~&~D-~D: " prev-num this-num)))
- (print-code-location-source-form prev-location 0)
- (when *print-location-kind*
- (format t "~S " (sb!di:code-location-kind prev-location)))
- (when (location-in-list prev-location *breakpoints*)
- (format t " *Active*"))
- (when (sb!di:code-location= prev-location continue-at)
- (format t " *Continue here*")))))
-
- (dolist (code-location *possible-breakpoints*)
- (when (or *print-location-kind*
- (location-in-list code-location *breakpoints*)
- (sb!di:code-location= code-location continue-at)
- (not prev-location)
- (not (eq (sb!di:code-location-debug-source code-location)
- (sb!di:code-location-debug-source prev-location)))
- (not (eq (sb!di:code-location-top-level-form-offset
- code-location)
- (sb!di:code-location-top-level-form-offset
- prev-location)))
- (not (eq (sb!di:code-location-form-number code-location)
- (sb!di:code-location-form-number prev-location))))
- (flush)
- (setq prev-location code-location prev-num this-num))
-
- (incf this-num))))
-
- (when (location-in-list *default-breakpoint-debug-function*
- *breakpoints*
- :function-end)
- (format t "~&::FUNCTION-END *Active* "))))
-
-(!def-debug-command-alias "LL" "LIST-LOCATIONS")
-
-;;; Set breakpoint at the given number.
-(!def-debug-command "BREAKPOINT" ()
- (let ((index (read-prompting-maybe "location number, :START, or :END: "))
- (break t)
- (condition t)
- (print nil)
- (print-functions nil)
- (function nil)
- (bp)
- (place *default-breakpoint-debug-function*))
- (flet ((get-command-line ()
- (let ((command-line nil)
- (unique '(nil)))
- (loop
- (let ((next-input (read-if-available unique)))
- (when (eq next-input unique) (return))
- (push next-input command-line)))
- (nreverse command-line)))
- (set-vars-from-command-line (command-line)
- (do ((arg (pop command-line) (pop command-line)))
- ((not arg))
- (ecase arg
- (:condition (setf condition (pop command-line)))
- (:print (push (pop command-line) print))
- (:break (setf break (pop command-line)))
- (:function
- (setf function (eval (pop command-line)))
- (setf *default-breakpoint-debug-function*
- (sb!di:function-debug-function function))
- (setf place *default-breakpoint-debug-function*)
- (setf *possible-breakpoints*
- (possible-breakpoints
- *default-breakpoint-debug-function*))))))
- (setup-function-start ()
- (let ((code-loc (sb!di:debug-function-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
- place
- :kind :function-start))
- (setf break (sb!di:preprocess-for-eval break code-loc))
- (setf condition (sb!di:preprocess-for-eval condition code-loc))
- (dolist (form print)
- (push (cons (sb!di:preprocess-for-eval form code-loc) form)
- print-functions))))
- (setup-function-end ()
- (setf bp
- (sb!di:make-breakpoint #'main-hook-function
- place
- :kind :function-end))
- (setf break
- ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
- ;; forms should be converted to shiny new (LAMBDA ..) forms.
- ;; (Search the sources for "coerce.*\(lambda".)
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,break)
- 'function))
- (setf condition (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,condition)
- 'function))
- (dolist (form print)
- (push (cons
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,form) 'function)
- form)
- print-functions)))
- (setup-code-location ()
- (setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
- place
- :kind :code-location))
- (dolist (form print)
- (push (cons
- (sb!di:preprocess-for-eval form place)
- form)
- print-functions))
- (setf break (sb!di:preprocess-for-eval break place))
- (setf condition (sb!di:preprocess-for-eval condition place))))
- (set-vars-from-command-line (get-command-line))
- (cond
- ((or (eq index :start) (eq index :s))
- (setup-function-start))
- ((or (eq index :end) (eq index :e))
- (setup-function-end))
- (t
- (setup-code-location)))
- (sb!di:activate-breakpoint bp)
- (let* ((new-bp-info (create-breakpoint-info place bp index
- :break break
- :print print-functions
- :condition condition))
- (old-bp-info (location-in-list new-bp-info *breakpoints*)))
- (when old-bp-info
- (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
- old-bp-info))
- (setf *breakpoints* (remove old-bp-info *breakpoints*))
- (format t "previous breakpoint removed~%"))
- (push new-bp-info *breakpoints*))
- (print-breakpoint-info (first *breakpoints*))
- (format t "~&added"))))
-
-(!def-debug-command-alias "BP" "BREAKPOINT")
-
-;;; List all breakpoints which are set.
-(!def-debug-command "LIST-BREAKPOINTS" ()
- (setf *breakpoints*
- (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
- (dolist (info *breakpoints*)
- (print-breakpoint-info info)))
-
-(!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
-
-;;; Remove breakpoint N, or remove all breakpoints if no N given.
-(!def-debug-command "DELETE-BREAKPOINT" ()
- (let* ((index (read-if-available nil))
- (bp-info
- (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
- (cond (bp-info
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
- (setf *breakpoints* (remove bp-info *breakpoints*))
- (format t "breakpoint ~S removed~%" index))
- (index (format t "The breakpoint doesn't exist."))
- (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")
+(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)
+ "~@<Bogus form-number: the source file has ~
+ probably changed too much to cope with.~:@>"))))))
\f
+
+;;; 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-function curloc))
- (function (sb!di:debug-function-function debug-fun)))
+ (debug-fun (sb!di:code-location-debug-fun curloc))
+ (function (sb!di:debug-fun-fun debug-fun)))
(if function
- (describe function)
- (format t "can't figure out the function for this frame"))))
+ (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*
+ "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>")))
+
+(!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 "~@<No global function for the frame, but we ~
+ do have access to a function object that we ~
+ can try to call -- but if it is normally part ~
+ of a closure, then this is NOT going to end well.~_~_~
+ Try it anyways?~:@>")))
+ (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*
+ "~@<Can't restart ~S: tag not found. ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>"
+ *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))))
\f
;;;; 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))
projects / sbcl.git / blobdiff