;;; to satisfy lambda list
;;; #:
;;; exactly 2 expected, but 5 found
+;;;
+;;; FIXME: These variables were deprecated in late February 2004, and
+;;; can probably be removed in about a year.
(defvar *debug-print-level* 5
#!+sb-doc
- "*PRINT-LEVEL* for the debugger")
+ "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.)
+
+*PRINT-LEVEL* for the debugger")
(defvar *debug-print-length* 7
#!+sb-doc
- "*PRINT-LENGTH* for the debugger")
+ "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.)
+
+*PRINT-LENGTH* for the debugger")
+
+(defvar *debug-print-variable-alist* nil
+ #!+sb-doc
+ "an association list describing new bindings for special variables
+(typically *PRINT-FOO* variables) to be used within the debugger, e.g.
+((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))")
(defvar *debug-readtable*
;; KLUDGE: This can't be initialized in a cold toplevel form,
PRINT, P displays current function call.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
-Breakpoints and steps:
- LIST-LOCATIONS [{function | :C}] List the locations for breakpoints.
- Specify :C for the current frame.
- Abbreviation: LL
- LIST-BREAKPOINTS List the active breakpoints.
- Abbreviations: LB, LBP
- DELETE-BREAKPOINT [n] Remove breakpoint n or all breakpoints.
- Abbreviations: DEL, DBP
- BREAKPOINT {n | :end | :start} [:break form] [:function function]
- [{:print form}*] [:condition form]
- Set a breakpoint.
- Abbreviations: BR, BP
- STEP [n] Step to the next location or step n times.
+Stepping:
+ STEP
+ [EXPERIMENTAL] Selects the CONTINUE restart if one exists and starts
+ single-stepping. Single stepping affects only code compiled with
+ under high DEBUG optimization quality. See User Manul for details.
Function and macro commands:
(SB-DEBUG:ARG n)
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-fun* nil)
-(declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*))
-\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)))
-
-;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN.
-(defun possible-breakpoints (debug-fun)
- (let ((possible-breakpoints nil))
- (sb!di:do-debug-fun-blocks (debug-block debug-fun)
- (unless (sb!di:debug-block-elsewhere-p debug-block)
- (if *only-block-start-locations*
- (push (first-code-location debug-block) possible-breakpoints)
- (sb!di:do-debug-block-locations (code-location debug-block)
- (when (not (member (sb!di:code-location-kind code-location)
- *bad-code-location-types*))
- (push code-location possible-breakpoints))))))
- (nreverse possible-breakpoints)))
-
-;;; Search the info-list for the item passed (CODE-LOCATION,
-;;; DEBUG-FUN, or BREAKPOINT-INFO). If the item passed is a debug
-;;; function then kind will be compared if it was specified. The kind
-;;; if also compared if a breakpoint-info is passed since it's in the
-;;; breakpoint. The info structure is returned if found.
-(defun location-in-list (place info-list &optional (kind nil))
- (when (breakpoint-info-p place)
- (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
- (setf place (breakpoint-info-place place)))
- (cond ((sb!di:code-location-p place)
- (find place info-list
- :key #'breakpoint-info-place
- :test (lambda (x y) (and (sb!di:code-location-p y)
- (sb!di:code-location= x y)))))
- (t
- (find place info-list
- :test (lambda (x-debug-fun y-info)
- (let ((y-place (breakpoint-info-place y-info))
- (y-breakpoint (breakpoint-info-breakpoint
- y-info)))
- (and (sb!di:debug-fun-p y-place)
- (eq x-debug-fun y-place)
- (or (not kind)
- (eq kind (sb!di:breakpoint-kind
- y-breakpoint))))))))))
;;; If LOC is an unknown location, then try to find the block start
;;; location. Used by source printing to some information instead of
loc)))
loc))
\f
-;;;; the BREAKPOINT-INFO structure
-
-;;; info about a made breakpoint
-(defstruct (breakpoint-info (:copier nil)
- (:constructor %make-breakpoint-info))
- ;; where we are going to stop
- (place (missing-arg)
- :type (or sb!di:code-location sb!di:debug-fun)
- :read-only t)
- ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT
- (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t)
- ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
- ;; non-NIL, drop into the debugger.
- (break #'identity :type function :read-only t)
- ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
- ;; non-NIL, eval (each) print and print results.
- (condition #'identity :type function :read-only t)
- ;; the list of functions from SB!DI:PREPROCESS-FOR-EVAL to evaluate.
- ;; Results are conditionally printed. CAR of each element is the
- ;; function, CDR is the form it goes with.
- (print nil :type list :read-only t)
- ;; the number used when listing the possible breakpoints within a
- ;; function; or could also be a symbol such as START or END
- (code-location-selector (missing-arg) :type (or symbol integer) :read-only t)
- ;; the number used when listing the active breakpoints, and when
- ;; deleting breakpoints
- (breakpoint-number (missing-arg) :type integer :read-only t))
-
-(defun create-breakpoint-info (place breakpoint code-location-selector
- &key (break #'identity)
- (condition #'identity) (print nil))
- (setf *breakpoints*
- (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
- (let ((breakpoint-number
- (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
- ((or (> i (length *breakpoints*))
- (not (= i (breakpoint-info-breakpoint-number
- (first breakpoints)))))
-
- i))))
- (%make-breakpoint-info :place place
- :breakpoint breakpoint
- :code-location-selector code-location-selector
- :breakpoint-number breakpoint-number
- :break break
- :condition condition
- :print print)))
-
-(defun print-breakpoint-info (breakpoint-info)
- (let ((place (breakpoint-info-place breakpoint-info))
- (bp-number (breakpoint-info-breakpoint-number breakpoint-info)))
- (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
- (:code-location
- (print-code-location-source-form place 0)
- (format t
- "~&~S: ~S in ~S"
- bp-number
- (breakpoint-info-code-location-selector breakpoint-info)
- (sb!di:debug-fun-name (sb!di:code-location-debug-fun place))))
- (:fun-start
- (format t "~&~S: FUN-START in ~S" bp-number
- (sb!di:debug-fun-name place)))
- (:fun-end
- (format t "~&~S: FUN-END in ~S" bp-number
- (sb!di:debug-fun-name place))))))
-\f
-;;;; MAIN-HOOK-FUN for steps and breakpoints
-
-;;; This must be passed as the hook function. It keeps track of where
-;;; STEP breakpoints are.
-(defun main-hook-fun (current-frame breakpoint &optional return-vals
- fun-end-cookie)
- (setf *default-breakpoint-debug-fun*
- (sb!di:frame-debug-fun current-frame))
- (dolist (step-info *step-breakpoints*)
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info))
- (let ((bp-info (location-in-list step-info *breakpoints*)))
- (when bp-info
- (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
- (let ((*stack-top-hint* current-frame)
- (step-hit-info
- (location-in-list (sb!di:breakpoint-what breakpoint)
- *step-breakpoints*
- (sb!di:breakpoint-kind breakpoint)))
- (bp-hit-info
- (location-in-list (sb!di:breakpoint-what breakpoint)
- *breakpoints*
- (sb!di:breakpoint-kind breakpoint)))
- (break)
- (condition)
- (string ""))
- (setf *step-breakpoints* nil)
- (labels ((build-string (str)
- (setf string (concatenate 'string string str)))
- (print-common-info ()
- (build-string
- (with-output-to-string (*standard-output*)
- (when fun-end-cookie
- (format t "~%Return values: ~S" return-vals))
- (when condition
- (when (breakpoint-info-print bp-hit-info)
- (format t "~%")
- (print-frame-call current-frame))
- (dolist (print (breakpoint-info-print bp-hit-info))
- (format t "~& ~S = ~S" (rest print)
- (funcall (first print) current-frame))))))))
- (when bp-hit-info
- (setf break (funcall (breakpoint-info-break bp-hit-info)
- current-frame))
- (setf condition (funcall (breakpoint-info-condition bp-hit-info)
- current-frame)))
- (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
- (build-string (format nil "~&*Step (to a breakpoint)*"))
- (print-common-info)
- (break string))
- ((and bp-hit-info step-hit-info break)
- (build-string (format nil "~&*Step (to a breakpoint)*"))
- (print-common-info)
- (break string))
- ((and bp-hit-info step-hit-info)
- (print-common-info)
- (format t "~A" string)
- (decf *number-of-steps*)
- (set-step-breakpoint current-frame))
- ((and step-hit-info (= 1 *number-of-steps*))
- (build-string "*Step*")
- (break (make-condition 'step-condition :format-control string)))
- (step-hit-info
- (decf *number-of-steps*)
- (set-step-breakpoint current-frame))
- (bp-hit-info
- (when break
- (build-string (format nil "~&*Breakpoint hit*")))
- (print-common-info)
- (if break
- (break string)
- (format t "~A" string)))
- (t
- (break "unknown breakpoint"))))))
-\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-fun code-location
- :kind :code-location)))
- (sb!di:activate-breakpoint bp)
- (push (create-breakpoint-info code-location bp 0)
- *step-breakpoints*))))
- (t
- (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
- :kind :fun-end)))
- (sb!di:activate-breakpoint bp)
- (push (create-breakpoint-info debug-fun bp 0)
- *step-breakpoints*))))))))
-\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)
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*)
-(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))))
-
- ;; If we're a background thread and *background-threads-wait-for-debugger*
- ;; is NIL, this will invoke a restart
-
- ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it
- ;; around sbcl-0.7.8.5 (by which time it had mutated to have a
- ;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed
- ;; on SunOS and no one knew why it was needed anywhere else either).
- ;; So if something mysteriously breaks that has worked since the CMU
- ;; CL days, that might be why. -- WHN 2002-09-28
-
- ;; 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*))
-
+;;; 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
(original-package *package*)
(original-print-pretty *print-pretty*))
(with-standard-io-syntax
- (let ((*debug-condition* condition)
- (*debug-restarts* (compute-restarts condition))
- (*nested-debug-condition* nil)
- ;; We want the printer and reader to be in a useful state,
+ (let (;; We want the printer and reader to be in a useful state,
;; regardless of where the debugger was invoked in the
;; program. WITH-STANDARD-IO-SYNTAX did much of what we
;; want, but
;; We try to address all these issues with explicit
;; rebindings here.
(sb!kernel:*current-level-in-print* 0)
+ (*package* original-package)
+ (*print-pretty* original-print-pretty)
+ (*print-readably* nil)
+ ;; Clear the circularity machinery to try to to reduce the
+ ;; pain from sharing the circularity table across all
+ ;; streams; if these are not rebound here, then setting
+ ;; *PRINT-CIRCLE* within the debugger when debugging in a
+ ;; state where something circular was being printed (e.g.,
+ ;; because the debugger was entered on an error in a
+ ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
+ ;; here does seem somewhat ugly because it makes it more
+ ;; difficult to debug the printing-of-circularities code
+ ;; itself; however, as far as I (WHN, 2004-05-29) can see,
+ ;; that's almost entirely academic as long as there's one
+ ;; shared *C-H-T* for all streams (i.e., it's already
+ ;; unreasonably difficult to debug print-circle machinery
+ ;; given the buggy crosstalk between the debugger streams
+ ;; and the stream you're trying to watch), and any fix for
+ ;; that buggy arrangement will likely let this hack go away
+ ;; naturally.
+ (sb!impl::*circularity-hash-table* . nil)
+ (sb!impl::*circularity-counter* . nil)
+ ;; These rebindings are now (as of early 2004) deprecated,
+ ;; with the new *PRINT-VAR-ALIST* mechanism preferred.
(*print-length* *debug-print-length*)
(*print-level* *debug-print-level*)
- (*readtable* *debug-readtable*)
- (*print-readably* nil)
- (*package* original-package)
- (background-p nil)
- (*print-pretty* original-print-pretty))
-
- ;; Before we start our own output, finish any pending output.
- ;; Otherwise, if the user tried to track the progress of his
- ;; program using PRINT statements, he'd tend to lose the last
- ;; line of output or so, which'd be confusing.
- (flush-standard-output-streams)
-
- ;; (The initial output here goes to *ERROR-OUTPUT*, because the
- ;; initial output is not interactive, just an error message,
- ;; and when people redirect *ERROR-OUTPUT*, they could
- ;; reasonably expect to see error messages logged there,
- ;; regardless of what the debugger does afterwards.)
- (handler-case
- (format *error-output*
- "~2&~@<debugger invoked on condition of type ~S: ~
+ (*readtable* *debug-readtable*))
+ (progv
+ ;; (Why NREVERSE? PROGV makes the later entries have
+ ;; precedence over the earlier entries.
+ ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
+ ;; expected that its earlier entries have precedence. And
+ ;; the earlier-has-precedence behavior is mostly more
+ ;; convenient, so that programmers can use PUSH or LIST* to
+ ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
+ (nreverse (mapcar #'car *debug-print-variable-alist*))
+ (nreverse (mapcar #'cdr *debug-print-variable-alist*))
+ (apply fun rest))))))
+
+;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by
+;;; command-line --disable-debugger option
+(defun invoke-debugger (condition)
+ #!+sb-doc
+ "Enter the debugger."
+
+ (let ((old-hook *debugger-hook*))
+ (when old-hook
+ (let ((*debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
+ (let ((old-hook *invoke-debugger-hook*))
+ (when old-hook
+ (let ((*invoke-debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
+
+ ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the
+ ;; signal state in the case that we wind up in the debugger as a
+ ;; result of something done by a signal handler. It's not
+ ;; altogether obvious that this is necessary, and indeed SBCL has
+ ;; not been doing it since 0.7.8.5. But nobody seems altogether
+ ;; convinced yet
+ ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28
+
+ ;; We definitely want *PACKAGE* to be of valid type.
+ ;;
+ ;; Elsewhere in the system, we use the SANE-PACKAGE function for
+ ;; this, but here causing an exception just as we're trying to handle
+ ;; an exception would be confusing, so instead we use a special hack.
+ (unless (and (packagep *package*)
+ (package-name *package*))
+ (setf *package* (find-package :cl-user))
+ (format *error-output*
+ "The value of ~S was not an undeleted PACKAGE. It has been
+reset to ~S."
+ '*package* *package*))
+
+ ;; Before we start our own output, finish any pending output.
+ ;; Otherwise, if the user tried to track the progress of his program
+ ;; using PRINT statements, he'd tend to lose the last line of output
+ ;; or so, which'd be confusing.
+ (flush-standard-output-streams)
+
+ (funcall-with-debug-io-syntax #'%invoke-debugger condition))
+
+(defun %invoke-debugger (condition)
+
+ (let ((*debug-condition* condition)
+ (*debug-restarts* (compute-restarts condition))
+ (*nested-debug-condition* nil))
+ (handler-case
+ ;; (The initial output here goes to *ERROR-OUTPUT*, because the
+ ;; initial output is not interactive, just an error message, and
+ ;; when people redirect *ERROR-OUTPUT*, they could reasonably
+ ;; expect to see error messages logged there, regardless of what
+ ;; the debugger does afterwards.)
+ (format *error-output*
+ "~2&~@<debugger invoked on a ~S in thread ~A: ~
~2I~_~A~:>~%"
- (type-of *debug-condition*)
- *debug-condition*)
- (error (condition)
- (setf *nested-debug-condition* condition)
- (let ((ndc-type (type-of *nested-debug-condition*)))
- (format *error-output*
- "~&~@<(A ~S was caught when trying to print ~S when ~
+ (type-of *debug-condition*)
+ (sb!thread:current-thread-id)
+ *debug-condition*)
+ (error (condition)
+ (setf *nested-debug-condition* condition)
+ (let ((ndc-type (type-of *nested-debug-condition*)))
+ (format *error-output*
+ "~&~@<(A ~S was caught when trying to print ~S when ~
entering the debugger. Printing was aborted and the ~
~S was stored in ~S.)~@:>~%"
- ndc-type
- '*debug-condition*
- ndc-type
- '*nested-debug-condition*))
- (when (typep condition 'cell-error)
- ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
- (format *error-output*
- "~&(CELL-ERROR-NAME ~S) = ~S~%"
- '*debug-condition*
- (cell-error-name *debug-condition*)))))
-
- ;; After the initial error/condition/whatever announcement to
- ;; *ERROR-OUTPUT*, we become interactive, and should talk on
- ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
- ;; statement, not a description of reality.:-| There's a lot of
- ;; older debugger code which was written to do i/o on whatever
- ;; stream was in fashion at the time, and not all of it has
- ;; been converted to behave this way. -- WHN 2000-11-16)
-
- (setf background-p
- (sb!thread::debugger-wait-until-foreground-thread *debug-io*))
- (unwind-protect
- (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
- ;; used to rebind *STANDARD-INPUT* here too, but that's
- ;; been fixed already.)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
- ;; *ERROR-OUTPUT* to some log file, it's probably wrong
- ;; to send errors which occur in interactive debugging to
- ;; that file, and right to send them to *DEBUG-IO*.
- (*error-output* *debug-io*))
- (unless (typep condition 'step-condition)
- (when *debug-beginner-help-p*
- (format *debug-io*
- "~%~@<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))
- (when background-p (sb!thread::release-foreground)))))))
+ ndc-type
+ '*debug-condition*
+ ndc-type
+ '*nested-debug-condition*))
+ (when (typep condition 'cell-error)
+ ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+ (format *error-output*
+ "~&(CELL-ERROR-NAME ~S) = ~S~%"
+ '*debug-condition*
+ (cell-error-name *debug-condition*)))))
+
+ (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
+ *debug-io*)))
+
+ ;; After the initial error/condition/whatever announcement to
+ ;; *ERROR-OUTPUT*, we become interactive, and should talk on
+ ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
+ ;; statement, not a description of reality.:-| There's a lot of
+ ;; older debugger code which was written to do i/o on whatever
+ ;; stream was in fashion at the time, and not all of it has
+ ;; been converted to behave this way. -- WHN 2000-11-16)
+
+ (unwind-protect
+ (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
+ ;; violating the principle of least surprise, and making
+ ;; it impossible for the user to do reasonable things
+ ;; like using PRINT at the debugger prompt to send output
+ ;; to the program's ordinary (possibly
+ ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
+ ;; used to rebind *STANDARD-INPUT* here too, but that's
+ ;; been fixed already.)
+ (*standard-output* *debug-io*)
+ ;; This seems reasonable: e.g. if the user has redirected
+ ;; *ERROR-OUTPUT* to some log file, it's probably wrong
+ ;; to send errors which occur in interactive debugging to
+ ;; that file, and right to send them to *DEBUG-IO*.
+ (*error-output* *debug-io*))
+ (unless (typep condition 'step-condition)
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<You can type HELP for debugger help, or ~
+ (SB-EXT:QUIT) 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 me)
+ (declare (ignore me))
+ ;; There is no one there to interact with, so report the
+ ;; condition and terminate the program.
+ (flet ((failure-quit (&key recklessly-p)
+ (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
+ (quit :unix-status 1 :recklessly-p recklessly-p)))
+ ;; This HANDLER-CASE is here mostly to stop output immediately
+ ;; (and fall through to QUIT) when there's an I/O error. Thus,
+ ;; when we're run under a shell script or something, we can die
+ ;; cleanly when the script dies (and our pipes are cut), instead
+ ;; of falling into ldb or something messy like that. Similarly, we
+ ;; can terminate cleanly even if BACKTRACE dies because of bugs in
+ ;; user PRINT-OBJECT methods.
+ (handler-case
+ (progn
+ (format *error-output*
+ "~&~@<unhandled ~S in thread ~S: ~2I~_~A~:>~2%"
+ (type-of condition)
+ (sb!thread:current-thread-id)
+ condition)
+ ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
+ ;; even if we hit an error within BACKTRACE (e.g. a bug in
+ ;; the debugger's own frame-walking code, or a bug in a user
+ ;; PRINT-OBJECT method) we'll at least have the CONDITION
+ ;; printed out before we die.
+ (finish-output *error-output*)
+ ;; (Where to truncate the BACKTRACE is of course arbitrary, but
+ ;; it seems as though we should at least truncate it somewhere.)
+ (sb!debug:backtrace 128 *error-output*)
+ (format
+ *error-output*
+ "~%unhandled condition in --disable-debugger mode, quitting~%")
+ (finish-output *error-output*)
+ (failure-quit))
+ (condition ()
+ ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
+ ;; fail when our output streams are blown away, as e.g. when
+ ;; we're running under a Unix shell script and it dies somehow
+ ;; (e.g. because of a SIGINT). In that case, we might as well
+ ;; just give it up for a bad job, and stop trying to notify
+ ;; the user of anything.
+ ;;
+ ;; Actually, the only way I've run across to exercise the
+ ;; problem is to have more than one layer of shell script.
+ ;; I have a shell script which does
+ ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
+ ;; and the problem occurs when I interrupt this with Ctrl-C
+ ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
+ ;; I haven't figured out whether it's bash, time, tee, Linux, or
+ ;; what that is responsible, but that it's possible at all
+ ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
+ (ignore-errors
+ (%primitive print
+ "Argh! error within --disable-debugger error handling"))
+ (failure-quit :recklessly-p t)))))
+
+;;; halt-on-failures and prompt-on-failures modes, suitable for
+;;; noninteractive and interactive use respectively
+(defun disable-debugger ()
+ (when (eql *invoke-debugger-hook* nil)
+ (setf *debug-io* *error-output*
+ *invoke-debugger-hook* 'debugger-disabled-hook)))
+
+(defun enable-debugger ()
+ (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *invoke-debugger-hook* nil)))
+
+(setf *debug-io* *query-io*)
(defun show-restarts (restarts s)
(cond ((null restarts)
"~&(no restarts: If you didn't do this on purpose, ~
please report it as a bug.)~%"))
(t
- (format s "~&restarts:~%")
+ (format s "~&restarts (invokable by number or by ~
+ possibly-abbreviated name):~%")
(let ((count 0)
(names-used '(nil))
(max-name-len 0))
(push name names-used))))
(incf count))))))
+(defvar *debug-loop-fun* #'debug-loop-fun
+ "a function taking no parameters that starts the low-level debug loop")
+
;;; This calls DEBUG-LOOP, performing some simple initializations
;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
(*read-suppress* nil))
(unless (typep *debug-condition* 'step-condition)
(clear-input *debug-io*))
- (debug-loop)))
+ (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-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*))
;; and output on T seems broken.
(format t
"~&error flushed (because ~
- ~S is set)"
+ ~S is set)"
'*flush-debug-errors*)
(/show0 "throwing DEBUG-LOOP-CATCHER")
(throw 'debug-loop-catcher nil)))))
(cond
((not any-p)
(format t "There are no local variables ~@[starting with ~A ~]~
- in the function."
+ in the function."
prefix))
((not any-valid-p)
(format t "All variables ~@[starting with ~A ~]currently ~
- have invalid values."
+ have invalid values."
prefix))))
(write-line "There is no variable information available."))))
(defvar *cached-readtable* nil)
(declaim (type (or readtable null) *cached-readtable*))
-(pushnew (lambda ()
- (setq *cached-debug-source* nil *cached-source-stream* nil
- *cached-readtable* nil))
- *before-save-initializations*)
+;;; Stuff to clean up before saving a core
+(defun debug-deinit ()
+ (setf *cached-debug-source* nil
+ *cached-source-stream* nil
+ *cached-readtable* nil))
;;; We also cache the last toplevel form that we printed a source for
;;; so that we don't have to do repeated reads and calls to
(file-position *cached-source-stream* char-offset))
(t
(format t "~%; File has been modified since compilation:~%; ~A~@
- ; Using form offset instead of character position.~%"
+ ; Using form offset instead of character position.~%"
(namestring name))
(file-position *cached-source-stream* 0)
(let ((*read-suppress* t))
(svref translations form-num)
context)))))
\f
-;;; breakpoint and step commands
-
-;;; Step to the next code-location.
+;;; step to the next steppable form
(!def-debug-command "STEP" ()
- (setf *number-of-steps* (read-if-available 1))
- (set-step-breakpoint *current-frame*)
- (continue *debug-condition*)
- (error "couldn't continue"))
-
-;;; List possible breakpoint locations, which ones are active, and
-;;; where the CONTINUE restart will transfer control. Set
-;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
-;;; used by sbreakpoint.
-(!def-debug-command "LIST-LOCATIONS" ()
- (let ((df (read-if-available *default-breakpoint-debug-fun*)))
- (cond ((consp df)
- (setf df (sb!di:fun-debug-fun (eval df)))
- (setf *default-breakpoint-debug-fun* df))
- ((or (eq ':c df)
- (not *default-breakpoint-debug-fun*))
- (setf df (sb!di:frame-debug-fun *current-frame*))
- (setf *default-breakpoint-debug-fun* df)))
- (setf *possible-breakpoints* (possible-breakpoints df)))
- (let ((continue-at (sb!di:frame-code-location *current-frame*)))
- (let ((active (location-in-list *default-breakpoint-debug-fun*
- *breakpoints* :fun-start))
- (here (sb!di:code-location=
- (sb!di:debug-fun-start-location
- *default-breakpoint-debug-fun*) continue-at)))
- (when (or active here)
- (format t "::FUN-START ")
- (when active (format t " *Active*"))
- (when here (format t " *Continue here*"))))
-
- (let ((prev-location nil)
- (prev-num 0)
- (this-num 0))
- (flet ((flush ()
- (when prev-location
- (let ((this-num (1- this-num)))
- (if (= prev-num this-num)
- (format t "~&~W: " prev-num)
- (format t "~&~W-~W: " prev-num this-num)))
- (print-code-location-source-form prev-location 0)
- (when *print-location-kind*
- (format t "~S " (sb!di:code-location-kind prev-location)))
- (when (location-in-list prev-location *breakpoints*)
- (format t " *Active*"))
- (when (sb!di:code-location= prev-location continue-at)
- (format t " *Continue here*")))))
-
- (dolist (code-location *possible-breakpoints*)
- (when (or *print-location-kind*
- (location-in-list code-location *breakpoints*)
- (sb!di:code-location= code-location continue-at)
- (not prev-location)
- (not (eq (sb!di:code-location-debug-source code-location)
- (sb!di:code-location-debug-source prev-location)))
- (not (eq (sb!di:code-location-toplevel-form-offset
- code-location)
- (sb!di:code-location-toplevel-form-offset
- prev-location)))
- (not (eq (sb!di:code-location-form-number code-location)
- (sb!di:code-location-form-number prev-location))))
- (flush)
- (setq prev-location code-location prev-num this-num))
-
- (incf this-num))))
-
- (when (location-in-list *default-breakpoint-debug-fun*
- *breakpoints*
- :fun-end)
- (format t "~&::FUN-END *Active* "))))
-
-(!def-debug-command-alias "LL" "LIST-LOCATIONS")
-
-;;; Set breakpoint at the given number.
-(!def-debug-command "BREAKPOINT" ()
- (let ((index (read-prompting-maybe "location number, :START, or :END: "))
- (break t)
- (condition t)
- (print nil)
- (print-functions nil)
- (function nil)
- (bp)
- (place *default-breakpoint-debug-fun*))
- (flet ((get-command-line ()
- (let ((command-line nil)
- (unique '(nil)))
- (loop
- (let ((next-input (read-if-available unique)))
- (when (eq next-input unique) (return))
- (push next-input command-line)))
- (nreverse command-line)))
- (set-vars-from-command-line (command-line)
- (do ((arg (pop command-line) (pop command-line)))
- ((not arg))
- (ecase arg
- (:condition (setf condition (pop command-line)))
- (:print (push (pop command-line) print))
- (:break (setf break (pop command-line)))
- (:function
- (setf function (eval (pop command-line)))
- (setf *default-breakpoint-debug-fun*
- (sb!di:fun-debug-fun function))
- (setf place *default-breakpoint-debug-fun*)
- (setf *possible-breakpoints*
- (possible-breakpoints
- *default-breakpoint-debug-fun*))))))
- (setup-fun-start ()
- (let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-start))
- (setf break (sb!di:preprocess-for-eval break code-loc))
- (setf condition (sb!di:preprocess-for-eval condition code-loc))
- (dolist (form print)
- (push (cons (sb!di:preprocess-for-eval form code-loc) form)
- print-functions))))
- (setup-fun-end ()
- (setf bp
- (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-end))
- (setf break
- ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
- ;; forms should be converted to shiny new (LAMBDA ..) forms.
- ;; (Search the sources for "coerce.*\(lambda".)
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,break)
- 'function))
- (setf condition (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,condition)
- 'function))
- (dolist (form print)
- (push (cons
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,form) 'function)
- form)
- print-functions)))
- (setup-code-location ()
- (setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-fun place
- :kind :code-location))
- (dolist (form print)
- (push (cons
- (sb!di:preprocess-for-eval form place)
- form)
- print-functions))
- (setf break (sb!di:preprocess-for-eval break place))
- (setf condition (sb!di:preprocess-for-eval condition place))))
- (set-vars-from-command-line (get-command-line))
- (cond
- ((or (eq index :start) (eq index :s))
- (setup-fun-start))
- ((or (eq index :end) (eq index :e))
- (setup-fun-end))
- (t
- (setup-code-location)))
- (sb!di:activate-breakpoint bp)
- (let* ((new-bp-info (create-breakpoint-info place bp index
- :break break
- :print print-functions
- :condition condition))
- (old-bp-info (location-in-list new-bp-info *breakpoints*)))
- (when old-bp-info
- (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
- old-bp-info))
- (setf *breakpoints* (remove old-bp-info *breakpoints*))
- (format t "previous breakpoint removed~%"))
- (push new-bp-info *breakpoints*))
- (print-breakpoint-info (first *breakpoints*))
- (format t "~&added"))))
-
-(!def-debug-command-alias "BP" "BREAKPOINT")
-
-;;; List all breakpoints which are set.
-(!def-debug-command "LIST-BREAKPOINTS" ()
- (setf *breakpoints*
- (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
- (dolist (info *breakpoints*)
- (print-breakpoint-info info)))
-
-(!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
-
-;;; Remove breakpoint N, or remove all breakpoints if no N given.
-(!def-debug-command "DELETE-BREAKPOINT" ()
- (let* ((index (read-if-available nil))
- (bp-info
- (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
- (cond (bp-info
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
- (setf *breakpoints* (remove bp-info *breakpoints*))
- (format t "breakpoint ~S removed~%" index))
- (index (format t "The breakpoint doesn't exist."))
+ (let ((restart (find-restart 'continue *debug-condition*)))
+ (cond (restart
+ (setf *stepping* t
+ *step* t)
+ (invoke-restart restart))
(t
- (dolist (ele *breakpoints*)
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele)))
- (setf *breakpoints* nil)
- (format t "all breakpoints deleted~%")))))
+ (format *debug-io* "~&Non-continuable error, cannot step.~%")))))
-(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
-\f
;;; miscellaneous commands
(!def-debug-command "DESCRIBE" ()
projects / sbcl.git / blobdiff