3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!DEBUG")
14 ;;;; variables and constants
16 ;;; things to consider when tweaking these values:
17 ;;; * We're afraid to just default them to NIL and NIL, in case the
18 ;;; user inadvertently causes a hairy data structure to be printed
19 ;;; when he inadvertently enters the debugger.
20 ;;; * We don't want to truncate output too much. These days anyone
21 ;;; can easily run their Lisp in a windowing system or under Emacs,
22 ;;; so it's not the end of the world even if the worst case is a
23 ;;; few thousand lines of output.
24 ;;; * As condition :REPORT methods are converted to use the pretty
25 ;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
26 ;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
27 ;;; ARG-COUNT-ERROR printed as
28 ;;; error while parsing arguments to DESTRUCTURING-BIND:
29 ;;; invalid number of elements in
31 ;;; to satisfy lambda list
33 ;;; exactly 2 expected, but 5 found
34 (defvar *debug-print-variable-alist* nil
36 "an association list describing new bindings for special variables
37 to be used within the debugger. Eg.
39 ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))
41 The variables in the CAR positions are bound to the values in the CDR
42 during the execution of some debug commands. When evaluating arbitrary
43 expressions in the debugger, the normal values of the printer control
44 variables are in effect.
46 Initially empty, *DEBUG-PRINT-VARIABLE-ALIST* is typically used to
47 provide bindings for printer control variables.")
49 (defvar *debug-readtable*
50 ;; KLUDGE: This can't be initialized in a cold toplevel form,
51 ;; because the *STANDARD-READTABLE* isn't initialized until after
52 ;; cold toplevel forms have run. So instead we initialize it
53 ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
56 "*READTABLE* for the debugger")
58 (defvar *in-the-debugger* nil
60 "This is T while in the debugger.")
62 ;;; nestedness inside debugger command loops
63 (defvar *debug-command-level* 0)
65 ;;; If this is bound before the debugger is invoked, it is used as the
66 ;;; stack top by the debugger.
67 (defvar *stack-top-hint* nil)
69 (defvar *stack-top* nil)
70 (defvar *real-stack-top* nil)
72 (defvar *current-frame* nil)
74 ;;; Beginner-oriented help messages are important because you end up
75 ;;; in the debugger whenever something bad happens, or if you try to
76 ;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
77 ;;; But after memorizing them the wasted screen space gets annoying..
78 (defvar *debug-beginner-help-p* t
79 "Should the debugger display beginner-oriented help messages?")
81 (defun debug-prompt (stream)
82 (sb!thread::get-foreground)
85 (sb!di:frame-number *current-frame*)
86 (> *debug-command-level* 1)
87 *debug-command-level*))
89 (defparameter *debug-help-string*
90 "The debug prompt is square brackets, with number(s) indicating the current
91 control stack level and, if you've entered the debugger recursively, how
92 deeply recursed you are.
93 Any command -- including the name of a restart -- may be uniquely abbreviated.
94 The debugger rebinds various special variables for controlling i/o, sometimes
95 to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
96 its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
97 Debug commands do not affect *, //, and similar variables, but evaluation in
98 the debug loop does affect these variables.
99 SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
100 drop you deeper into the debugger. The default NIL allows recursive entry
103 Getting in and out of the debugger:
104 TOPLEVEL, TOP exits debugger and returns to top level REPL
105 RESTART invokes restart numbered as shown (prompt if not given).
106 ERROR prints the error condition and restart cases.
108 The number of any restart, or its name, or a unique abbreviation for its
109 name, is a valid command, and is the same as using RESTART to invoke
113 UP up frame DOWN down frame
114 BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
117 BACKTRACE [n] shows n frames going down the stack.
118 LIST-LOCALS, L lists locals in current frame.
119 PRINT, P displays function call for current frame.
120 SOURCE [n] displays frame's source form with n levels of enclosing forms.
123 START Selects the CONTINUE restart if one exists and starts
124 single-stepping. Single stepping affects only code compiled with
125 under high DEBUG optimization quality. See User Manual for details.
126 STEP Steps into the current form.
127 NEXT Steps over the current form.
128 OUT Stops stepping temporarily, but resumes it when the topmost frame that
129 was stepped into returns.
130 STOP Stops single-stepping.
132 Function and macro commands:
134 Return the n'th argument in the current frame.
135 (SB-DEBUG:VAR string-or-symbol [id])
136 Returns the value of the specified variable in the current frame.
140 Return the values resulting from evaluation of expr from the
141 current frame, if this frame was compiled with a sufficiently high
142 DEBUG optimization quality.
145 Restart execution of the current frame, if this frame is for a
146 global function which was compiled with a sufficiently high
147 DEBUG optimization quality.
150 Discard all pending input on *STANDARD-INPUT*. (This can be
151 useful when the debugger was invoked to handle an error in
152 deeply nested input syntax, and now the reader is confused.)")
155 ;;; If LOC is an unknown location, then try to find the block start
156 ;;; location. Used by source printing to some information instead of
157 ;;; none for the user.
158 (defun maybe-block-start-location (loc)
159 (if (sb!di:code-location-unknown-p loc)
160 (let* ((block (sb!di:code-location-debug-block loc))
161 (start (sb!di:do-debug-block-locations (loc block)
163 (cond ((and (not (sb!di:debug-block-elsewhere-p block))
165 (format *debug-io* "~%unknown location: using block start~%")
173 (defun map-backtrace (thunk &key (start 0) (count most-positive-fixnum))
177 for frame = (if *in-the-debugger*
180 then (sb!di:frame-down frame)
182 when (<= start index) do
183 (if (minusp (decf count))
185 (setf result (funcall thunk frame)))
186 finally (return result)))
188 (defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
190 "Show a listing of the call stack going down from the current frame.
191 In the debugger, the current frame is indicated by the prompt. COUNT
192 is how many frames to show."
194 (let ((*suppress-print-errors* (if (subtypep 'serious-condition *suppress-print-errors*)
195 *suppress-print-errors*
198 (handler-bind ((print-not-readable #'print-unreadably))
199 (map-backtrace (lambda (frame)
200 (print-frame-call frame stream :number t))
205 (defun backtrace-as-list (&optional (count most-positive-fixnum))
207 "Return a list representing the current BACKTRACE.
209 Objects in the backtrace with dynamic-extent allocation by the current
210 thread are represented by substitutes to avoid references to them from
211 leaking outside their legal extent."
212 (let ((reversed-result (list)))
213 (map-backtrace (lambda (frame)
214 (let ((frame-list (frame-call-as-list frame)))
215 (if (listp (cdr frame-list))
216 (push (mapcar #'replace-dynamic-extent-object frame-list)
218 (push frame-list reversed-result))))
220 (nreverse reversed-result)))
222 (defun frame-call-as-list (frame)
223 (multiple-value-bind (name args) (frame-call frame)
226 (defun replace-dynamic-extent-object (obj)
227 (if (stack-allocated-p obj)
228 (make-unprintable-object
230 (format nil "dynamic-extent: ~S" obj)
232 "error printing dynamic-extent object")))
235 (defun stack-allocated-p (obj)
236 "Returns T if OBJ is allocated on the stack of the current
237 thread, NIL otherwise."
238 (with-pinned-objects (obj)
239 (let ((sap (int-sap (get-lisp-obj-address obj))))
240 (when (sb!vm:control-stack-pointer-valid-p sap nil)
245 (eval-when (:compile-toplevel :execute)
247 ;;; This is a convenient way to express what to do for each type of
248 ;;; lambda-list element.
249 (sb!xc:defmacro lambda-list-element-dispatch (element
261 (ecase (car ,element)
262 (:optional ,@optional)
267 (aver (eq ,element :deleted))
270 (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
271 (let ((var (gensym)))
272 `(let ((,var ,variable))
273 (cond ((eq ,var :deleted) ,deleted)
274 ((eq (sb!di:debug-var-validity ,var ,location) :valid)
280 ;;; Extract the function argument values for a debug frame.
281 (defun map-frame-args (thunk frame)
282 (let ((debug-fun (sb!di:frame-debug-fun frame)))
283 (dolist (element (sb!di:debug-fun-lambda-list debug-fun))
284 (funcall thunk element))))
286 (defun frame-args-as-list (frame)
288 (let ((location (sb!di:frame-code-location frame))
289 (reversed-result nil))
293 (lambda-list-element-dispatch element
294 :required ((push (frame-call-arg element location frame) reversed-result))
295 :optional ((push (frame-call-arg (second element) location frame)
297 :keyword ((push (second element) reversed-result)
298 (push (frame-call-arg (third element) location frame)
300 :deleted ((push (frame-call-arg element location frame) reversed-result))
301 :rest ((lambda-var-dispatch (second element) location
303 (let ((rest (sb!di:debug-var-value (second element) frame)))
305 (setf reversed-result (append (reverse rest) reversed-result))
306 (push (make-unprintable-object "unavailable &REST argument")
308 (return-from enumerating))
309 (push (make-unprintable-object
310 "unavailable &REST argument")
312 :more ((lambda-var-dispatch (second element) location
314 (let ((context (sb!di:debug-var-value (second element) frame))
315 (count (sb!di:debug-var-value (third element) frame)))
316 (setf reversed-result
319 (sb!c::%more-arg-values context 0 count)))
321 (return-from enumerating))
322 (push (make-unprintable-object "unavailable &MORE argument")
325 (nreverse reversed-result))
326 (sb!di:lambda-list-unavailable ()
327 (make-unprintable-object "unavailable lambda list"))))
329 (defvar *show-entry-point-details* nil)
331 (defun clean-xep (name args)
332 (values (second name)
334 (let* ((count (first args))
335 (real-args (rest args)))
337 ;; So, this is a cheap trick -- but makes backtraces for
338 ;; too-many-arguments-errors much, much easier to to
339 ;; understand. FIXME: For :EXTERNAL frames at least we
340 ;; should be able to get the actual arguments, really.
342 for arg = (if real-args
344 (make-unprintable-object "unknown"))
349 (defun clean-&more-processor (name args)
350 (values (second name)
352 (let* ((more (last args 2))
353 (context (first more))
354 (count (second more)))
359 (sb!c:%more-arg-values context 0 count))
361 (make-unprintable-object "more unavailable arguments")))))
364 (defun frame-call (frame)
365 (labels ((clean-name-and-args (name args)
366 (if (and (consp name) (not *show-entry-point-details*))
367 ;; FIXME: do we need to deal with
368 ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
369 ;; &AUX-BINDINGS appear in backtraces, so they are
370 ;; left alone for now. --NS 2005-02-28
373 ;; The name of an evaluator thunk contains
374 ;; the source context -- but that makes for a
375 ;; confusing frame name, since it can look like an
376 ;; EVAL call with a bogus argument.
377 (values '#:eval-thunk nil))
378 ((sb!c::xep sb!c::tl-xep)
379 (clean-xep name args))
380 ((sb!c::&more-processor)
381 (clean-&more-processor name args))
382 ((sb!c::hairy-arg-processor
383 sb!c::varargs-entry sb!c::&optional-processor)
384 (clean-name-and-args (second name) args))
387 (values name args))))
388 (let ((debug-fun (sb!di:frame-debug-fun frame)))
389 (multiple-value-bind (name args)
390 (clean-name-and-args (sb!di:debug-fun-name debug-fun)
391 (frame-args-as-list frame))
392 (values name args (sb!di:debug-fun-kind debug-fun))))))
394 (defun ensure-printable-object (object)
396 (with-open-stream (out (make-broadcast-stream))
400 (declare (ignore cond))
401 (make-unprintable-object "error printing object"))))
403 (defun frame-call-arg (var location frame)
404 (lambda-var-dispatch var location
405 (make-unprintable-object "unused argument")
406 (sb!di:debug-var-value var frame)
407 (make-unprintable-object "unavailable argument")))
409 ;;; Prints a representation of the function call causing FRAME to
410 ;;; exist. VERBOSITY indicates the level of information to output;
411 ;;; zero indicates just printing the DEBUG-FUN's name, and one
412 ;;; indicates displaying call-like, one-liner format with argument
414 (defun print-frame-call (frame stream &key (verbosity 1) (number nil))
416 (format stream "~&~S: " (sb!di:frame-number frame)))
417 (if (zerop verbosity)
418 (let ((*print-readably* nil))
419 (prin1 frame stream))
420 (multiple-value-bind (name args kind) (frame-call frame)
421 (pprint-logical-block (stream nil :prefix "(" :suffix ")")
422 ;; Since we go to some trouble to make nice informative function
423 ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
424 ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
425 ;; For the function arguments, we can just print normally.
426 (let ((*print-length* nil)
429 ;; If we hit a &REST arg, then print as many of the values
430 ;; as possible, punting the loop over lambda-list variables
431 ;; since any other arguments will be in the &REST arg's list
432 ;; of values. Special case *PRINT-PRETTY* for eval frames:
433 ;; if *PRINT-LINES* is 1, turn off pretty-printing.
434 (let ((*print-pretty*
435 (if (and (eql 1 *print-lines*)
436 (member name '(eval simple-eval-in-lexenv)))
440 (format stream "~{ ~_~S~}" args)
441 (format stream " ~S" args)))
443 (format stream "[~S]" kind))))
444 (when (>= verbosity 2)
445 (let ((loc (sb!di:frame-code-location frame)))
448 ;; FIXME: Is this call really necessary here? If it is,
449 ;; then the reason for it should be unobscured.
450 (sb!di:code-location-debug-block loc)
451 (format stream "~%source: ")
452 (prin1 (code-location-source-form loc 0) stream))
453 (sb!di:debug-condition (ignore)
456 (format stream "~&error finding source: ~A" c))))))
460 (defvar *debugger-hook* nil
462 "This is either NIL or a function of two arguments, a condition and the value
463 of *DEBUGGER-HOOK*. This function can either handle the condition or return
464 which causes the standard debugger to execute. The system passes the value
465 of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
466 around the invocation.")
468 (defvar *invoke-debugger-hook* nil
470 "This is either NIL or a designator for a function of two arguments,
471 to be run when the debugger is about to be entered. The function is
472 run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
473 errors, and receives as arguments the condition that triggered
474 debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
476 This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
477 In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
480 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
481 (defvar *debug-restarts*)
482 (defvar *debug-condition*)
483 (defvar *nested-debug-condition*)
485 ;;; Oh, what a tangled web we weave when we preserve backwards
486 ;;; compatibility with 1968-style use of global variables to control
487 ;;; per-stream i/o properties; there's really no way to get this
488 ;;; quite right, but we do what we can.
489 (defun funcall-with-debug-io-syntax (fun &rest rest)
490 (declare (type function fun))
491 ;; Try to force the other special variables into a useful state.
492 (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
493 ;; any default we might use is less useful than just reusing
494 ;; the global values.
495 (original-package *package*)
496 (original-print-pretty *print-pretty*))
497 (with-standard-io-syntax
499 (let (;; We want the printer and reader to be in a useful
500 ;; state, regardless of where the debugger was invoked
501 ;; in the program. WITH-STANDARD-IO-SYNTAX and
502 ;; WITH-SANE-IO-SYNTAX do much of what we want, but
503 ;; * It doesn't affect our internal special variables
504 ;; like *CURRENT-LEVEL-IN-PRINT*.
505 ;; * It isn't customizable.
506 ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not
507 ;; helpful behavior for a debugger.
508 ;; * There's no particularly good debugger default for
509 ;; *PRINT-PRETTY*, since T is usually what you want
510 ;; -- except absolutely not what you want when you're
511 ;; debugging failures in PRINT-OBJECT logic.
512 ;; We try to address all these issues with explicit
514 (sb!kernel:*current-level-in-print* 0)
515 (*package* original-package)
516 (*print-pretty* original-print-pretty)
517 ;; Clear the circularity machinery to try to to reduce the
518 ;; pain from sharing the circularity table across all
519 ;; streams; if these are not rebound here, then setting
520 ;; *PRINT-CIRCLE* within the debugger when debugging in a
521 ;; state where something circular was being printed (e.g.,
522 ;; because the debugger was entered on an error in a
523 ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
524 ;; here does seem somewhat ugly because it makes it more
525 ;; difficult to debug the printing-of-circularities code
526 ;; itself; however, as far as I (WHN, 2004-05-29) can see,
527 ;; that's almost entirely academic as long as there's one
528 ;; shared *C-H-T* for all streams (i.e., it's already
529 ;; unreasonably difficult to debug print-circle machinery
530 ;; given the buggy crosstalk between the debugger streams
531 ;; and the stream you're trying to watch), and any fix for
532 ;; that buggy arrangement will likely let this hack go away
534 (sb!impl::*circularity-hash-table* . nil)
535 (sb!impl::*circularity-counter* . nil)
536 (*readtable* *debug-readtable*))
538 ;; (Why NREVERSE? PROGV makes the later entries have
539 ;; precedence over the earlier entries.
540 ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
541 ;; expected that its earlier entries have precedence. And
542 ;; the earlier-has-precedence behavior is mostly more
543 ;; convenient, so that programmers can use PUSH or LIST* to
544 ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
545 (nreverse (mapcar #'car *debug-print-variable-alist*))
546 (nreverse (mapcar #'cdr *debug-print-variable-alist*))
547 (apply fun rest)))))))
549 ;;; This function is not inlined so it shows up in the backtrace; that
550 ;;; can be rather handy when one has to debug the interplay between
551 ;;; *INVOKE-DEBUGGER-HOOK* and *DEBUGGER-HOOK*.
552 (declaim (notinline run-hook))
553 (defun run-hook (variable condition)
554 (let ((old-hook (symbol-value variable)))
556 (progv (list variable) (list nil)
557 (funcall old-hook condition old-hook)))))
559 (defun invoke-debugger (condition)
561 "Enter the debugger."
563 ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
564 ;; called when the debugger is disabled
565 (run-hook '*invoke-debugger-hook* condition)
566 (run-hook '*debugger-hook* condition)
568 ;; We definitely want *PACKAGE* to be of valid type.
570 ;; Elsewhere in the system, we use the SANE-PACKAGE function for
571 ;; this, but here causing an exception just as we're trying to handle
572 ;; an exception would be confusing, so instead we use a special hack.
573 (unless (and (packagep *package*)
574 (package-name *package*))
575 (setf *package* (find-package :cl-user))
576 (format *error-output*
577 "The value of ~S was not an undeleted PACKAGE. It has been
579 '*package* *package*))
581 ;; Before we start our own output, finish any pending output.
582 ;; Otherwise, if the user tried to track the progress of his program
583 ;; using PRINT statements, he'd tend to lose the last line of output
584 ;; or so, which'd be confusing.
585 (flush-standard-output-streams)
587 (funcall-with-debug-io-syntax #'%invoke-debugger condition))
589 (defun %print-debugger-invocation-reason (condition stream)
590 (format stream "~2&")
591 ;; Note: Ordinarily it's only a matter of taste whether to use
592 ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
593 ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
594 ;; definitely preferred, because the FORMAT alternative was acting odd.
595 (pprint-logical-block (stream nil)
597 "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A"
599 #!+sb-thread sb!thread:*current-thread*
604 (defun %invoke-debugger (condition)
605 (let ((*debug-condition* condition)
606 (*debug-restarts* (compute-restarts condition))
607 (*nested-debug-condition* nil))
609 ;; (The initial output here goes to *ERROR-OUTPUT*, because the
610 ;; initial output is not interactive, just an error message, and
611 ;; when people redirect *ERROR-OUTPUT*, they could reasonably
612 ;; expect to see error messages logged there, regardless of what
613 ;; the debugger does afterwards.)
614 (unless (typep condition 'step-condition)
615 (%print-debugger-invocation-reason condition *error-output*))
617 (setf *nested-debug-condition* condition)
618 (let ((ndc-type (type-of *nested-debug-condition*)))
619 (format *error-output*
620 "~&~@<(A ~S was caught when trying to print ~S when ~
621 entering the debugger. Printing was aborted and the ~
622 ~S was stored in ~S.)~@:>~%"
626 '*nested-debug-condition*))
627 (when (typep *nested-debug-condition* 'cell-error)
628 ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
629 (format *error-output*
630 "~&(CELL-ERROR-NAME ~S) = ~S~%"
631 '*nested-debug-condition*
632 (cell-error-name *nested-debug-condition*)))))
634 (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
637 ;; After the initial error/condition/whatever announcement to
638 ;; *ERROR-OUTPUT*, we become interactive, and should talk on
639 ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
640 ;; statement, not a description of reality.:-| There's a lot of
641 ;; older debugger code which was written to do i/o on whatever
642 ;; stream was in fashion at the time, and not all of it has
643 ;; been converted to behave this way. -- WHN 2000-11-16)
646 (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
647 ;; here as well, but that is probably bogus since it
648 ;; removes the users ability to do output to a redirected
649 ;; *S-O*. Now we just rebind it so that users can temporarily
650 ;; frob it. FIXME: This and other "what gets bound when"
651 ;; behaviour should be documented in the manual.
652 (*standard-output* *standard-output*)
653 ;; This seems reasonable: e.g. if the user has redirected
654 ;; *ERROR-OUTPUT* to some log file, it's probably wrong
655 ;; to send errors which occur in interactive debugging to
656 ;; that file, and right to send them to *DEBUG-IO*.
657 (*error-output* *debug-io*))
658 (unless (typep condition 'step-condition)
659 (when *debug-beginner-help-p*
661 "~%~@<Type HELP for debugger help, or ~
662 (SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
663 (show-restarts *debug-restarts* *debug-io*))
666 (sb!thread::release-foreground))))))
668 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
669 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
670 ;;; command-line option
671 (defun debugger-disabled-hook (condition me)
672 (declare (ignore me))
673 ;; There is no one there to interact with, so report the
674 ;; condition and terminate the program.
675 (flet ((failure-quit (&key recklessly-p)
676 (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
677 (quit :unix-status 1 :recklessly-p recklessly-p)))
678 ;; This HANDLER-CASE is here mostly to stop output immediately
679 ;; (and fall through to QUIT) when there's an I/O error. Thus,
680 ;; when we're run under a shell script or something, we can die
681 ;; cleanly when the script dies (and our pipes are cut), instead
682 ;; of falling into ldb or something messy like that. Similarly, we
683 ;; can terminate cleanly even if BACKTRACE dies because of bugs in
684 ;; user PRINT-OBJECT methods.
687 (format *error-output*
688 "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
690 #!+sb-thread sb!thread:*current-thread*
693 ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
694 ;; even if we hit an error within BACKTRACE (e.g. a bug in
695 ;; the debugger's own frame-walking code, or a bug in a user
696 ;; PRINT-OBJECT method) we'll at least have the CONDITION
697 ;; printed out before we die.
698 (finish-output *error-output*)
699 ;; (Where to truncate the BACKTRACE is of course arbitrary, but
700 ;; it seems as though we should at least truncate it somewhere.)
701 (sb!debug:backtrace 128 *error-output*)
704 "~%unhandled condition in --disable-debugger mode, quitting~%")
705 (finish-output *error-output*)
708 ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
709 ;; fail when our output streams are blown away, as e.g. when
710 ;; we're running under a Unix shell script and it dies somehow
711 ;; (e.g. because of a SIGINT). In that case, we might as well
712 ;; just give it up for a bad job, and stop trying to notify
713 ;; the user of anything.
715 ;; Actually, the only way I've run across to exercise the
716 ;; problem is to have more than one layer of shell script.
717 ;; I have a shell script which does
718 ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
719 ;; and the problem occurs when I interrupt this with Ctrl-C
720 ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
721 ;; I haven't figured out whether it's bash, time, tee, Linux, or
722 ;; what that is responsible, but that it's possible at all
723 ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
726 "Argh! error within --disable-debugger error handling"))
727 (failure-quit :recklessly-p t)))))
729 (defvar *old-debugger-hook* nil)
731 ;;; halt-on-failures and prompt-on-failures modes, suitable for
732 ;;; noninteractive and interactive use respectively
733 (defun disable-debugger ()
734 "When invoked, this function will turn off both the SBCL debugger
735 and LDB (the low-level debugger). See also ENABLE-DEBUGGER."
736 ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
737 ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
738 ;; to set it to a suitable value again and be very careful,
739 ;; especially if the user has also set it. -- MG 2005-07-15
740 (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
741 (setf *old-debugger-hook* *invoke-debugger-hook*
742 *invoke-debugger-hook* 'debugger-disabled-hook))
743 ;; This is not inside the UNLESS to ensure that LDB is disabled
744 ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
745 ;; This might matter for example when restoring a core.
746 (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
747 (function sb!alien:void))))
749 (defun enable-debugger ()
750 "Restore the debugger if it has been turned off by DISABLE-DEBUGGER."
751 (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
752 (setf *invoke-debugger-hook* *old-debugger-hook*
753 *old-debugger-hook* nil))
754 (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler"
755 (function sb!alien:void))))
757 (defun show-restarts (restarts s)
758 (cond ((null restarts)
760 "~&(no restarts: If you didn't do this on purpose, ~
761 please report it as a bug.)~%"))
763 (format s "~&restarts (invokable by number or by ~
764 possibly-abbreviated name):~%")
768 (dolist (restart restarts)
769 (let ((name (restart-name restart)))
771 (let ((len (length (princ-to-string name))))
772 (when (> len max-name-len)
773 (setf max-name-len len))))))
774 (unless (zerop max-name-len)
775 (incf max-name-len 3))
776 (dolist (restart restarts)
777 (let ((name (restart-name restart)))
778 ;; FIXME: maybe it would be better to display later names
779 ;; in parens instead of brakets, not just omit them fully.
780 ;; Call BREAK, call BREAK in the debugger, and tell me
781 ;; it's not confusing looking. --NS 20050310
782 (cond ((member name names-used)
783 (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
785 (format s "~& ~2D: [~VA] ~A~%"
786 count (- max-name-len 3) name restart)
787 (push name names-used))))
790 (defvar *debug-loop-fun* #'debug-loop-fun
791 "a function taking no parameters that starts the low-level debug loop")
793 ;;; When the debugger is invoked due to a stepper condition, we don't
794 ;;; want to print the current frame before the first prompt for aesthetic
796 (defvar *suppress-frame-print* nil)
798 ;;; This calls DEBUG-LOOP, performing some simple initializations
799 ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
800 ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
801 ;;; to get into a debug prompt as quickly as possible with as little
802 ;;; risk as possible for stepping on whatever is causing recursive
804 (defun internal-debug ()
805 (let ((*in-the-debugger* t)
806 (*read-suppress* nil))
807 (unless (typep *debug-condition* 'step-condition)
808 (clear-input *debug-io*))
809 (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition)))
810 (funcall *debug-loop-fun*))))
814 ;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
815 ;;; was motivated by desire to play nicely with ILISP.
816 (defvar *flush-debug-errors* nil
818 "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
819 executing in the debugger.")
821 (defun debug-read (stream)
822 (declare (type stream stream))
823 (let* ((eof-marker (cons nil nil))
824 (form (read stream nil eof-marker)))
825 (if (eq form eof-marker)
829 (defun debug-loop-fun ()
830 (let* ((*debug-command-level* (1+ *debug-command-level*))
831 (*real-stack-top* (sb!di:top-frame))
832 (*stack-top* (or *stack-top-hint* *real-stack-top*))
833 (*stack-top-hint* nil)
834 (*current-frame* *stack-top*))
835 (handler-bind ((sb!di:debug-condition
837 (princ condition *debug-io*)
838 (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
839 (throw 'debug-loop-catcher nil))))
840 (cond (*suppress-frame-print*
841 (setf *suppress-frame-print* nil))
844 (print-frame-call *current-frame* *debug-io* :verbosity 2)))
846 (catch 'debug-loop-catcher
847 (handler-bind ((error (lambda (condition)
848 (when *flush-debug-errors*
849 (clear-input *debug-io*)
850 (princ condition *debug-io*)
852 "~&error flushed (because ~
854 '*flush-debug-errors*)
855 (/show0 "throwing DEBUG-LOOP-CATCHER")
856 (throw 'debug-loop-catcher nil)))))
857 ;; We have to bind LEVEL for the restart function created by
858 ;; WITH-SIMPLE-RESTART.
859 (let ((level *debug-command-level*)
860 (restart-commands (make-restart-commands)))
861 (flush-standard-output-streams)
862 (debug-prompt *debug-io*)
863 (force-output *debug-io*)
864 (let* ((exp (debug-read *debug-io*))
865 (cmd-fun (debug-command-p exp restart-commands)))
866 (with-simple-restart (abort
867 "~@<Reduce debugger level (to debug level ~W).~@:>"
870 (debug-eval-print exp))
873 "~&Your command, ~S, is ambiguous:~%"
875 (dolist (ele cmd-fun)
876 (format *debug-io* " ~A~%" ele)))
878 (funcall cmd-fun))))))))))))
880 (defvar *auto-eval-in-frame* t
882 "When set (the default), evaluations in the debugger's command loop occur
883 relative to the current frame's environment without the need of debugger
884 forms that explicitly control this kind of evaluation.")
886 (defun debug-eval (expr)
887 (cond ((not (and (fboundp 'compile) *auto-eval-in-frame*))
889 ((frame-has-debug-vars-p *current-frame*)
890 (sb!di:eval-in-frame *current-frame* expr))
892 (format *debug-io* "; No debug variables for current frame: ~
893 using EVAL instead of EVAL-IN-FRAME.~%")
896 (defun debug-eval-print (expr)
897 (/noshow "entering DEBUG-EVAL-PRINT" expr)
898 (let ((values (multiple-value-list
899 (interactive-eval expr :eval #'debug-eval))))
900 (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
901 (dolist (value values)
902 (fresh-line *debug-io*)
903 (prin1 value *debug-io*)))
904 (force-output *debug-io*))
906 ;;;; debug loop functions
908 ;;; These commands are functions, not really commands, so that users
909 ;;; can get their hands on the values returned.
911 (eval-when (:execute :compile-toplevel)
913 (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
914 `(let* ((temp (etypecase name
915 (symbol (sb!di:debug-fun-symbol-vars
916 (sb!di:frame-debug-fun *current-frame*)
918 (simple-string (sb!di:ambiguous-debug-vars
919 (sb!di:frame-debug-fun *current-frame*)
921 (location (sb!di:frame-code-location *current-frame*))
922 ;; Let's only deal with valid variables.
923 (vars (remove-if-not (lambda (v)
924 (eq (sb!di:debug-var-validity v location)
927 (declare (list vars))
929 (error "No known valid variables match ~S." name))
933 '(sb!di:debug-var-value (car vars) *current-frame*))
935 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
938 ;; Since we have more than one, first see whether we have
939 ;; any variables that exactly match the specification.
940 (let* ((name (etypecase name
941 (symbol (symbol-name name))
942 (simple-string name)))
943 ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
945 (exact (remove-if-not (lambda (v)
946 (string= (sb!di:debug-var-symbol-name v)
949 (vars (or exact vars)))
950 (declare (simple-string name)
953 ;; Check now for only having one variable.
957 '(sb!di:debug-var-value (car vars) *current-frame*))
959 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
961 ;; If there weren't any exact matches, flame about
962 ;; ambiguity unless all the variables have the same
967 (string= (sb!di:debug-var-symbol-name v)
968 (sb!di:debug-var-symbol-name (car vars))))
970 (error "specification ambiguous:~%~{ ~A~%~}"
971 (mapcar #'sb!di:debug-var-symbol-name
974 :key #'sb!di:debug-var-symbol-name))))
975 ;; All names are the same, so see whether the user
976 ;; ID'ed one of them.
978 (let ((v (find id vars :key #'sb!di:debug-var-id)))
981 "invalid variable ID, ~W: should have been one of ~S"
983 (mapcar #'sb!di:debug-var-id vars)))
986 '(sb!di:debug-var-value v *current-frame*))
988 `(setf (sb!di:debug-var-value v *current-frame*)
991 (error "Specify variable ID to disambiguate ~S. Use one of ~S."
993 (mapcar #'sb!di:debug-var-id vars)))))))))
997 ;;; FIXME: This doesn't work. It would be real nice we could make it
998 ;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
999 (defun var (name &optional (id 0 id-supplied))
1001 "Return a variable's value if possible. NAME is a simple-string or symbol.
1002 If it is a simple-string, it is an initial substring of the variable's name.
1003 If name is a symbol, it has the same name and package as the variable whose
1004 value this function returns. If the symbol is uninterned, then the variable
1005 has the same name as the symbol, but it has no package.
1007 If name is the initial substring of variables with different names, then
1008 this return no values after displaying the ambiguous names. If name
1009 determines multiple variables with the same name, then you must use the
1010 optional id argument to specify which one you want. If you left id
1011 unspecified, then this returns no values after displaying the distinguishing
1014 The result of this function is limited to the availability of variable
1015 information. This is SETF'able."
1016 (define-var-operation :ref))
1017 (defun (setf var) (value name &optional (id 0 id-supplied))
1018 (define-var-operation :set value))
1020 ;;; This returns the COUNT'th arg as the user sees it from args, the
1021 ;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
1022 ;;; potential DEBUG-VAR from the lambda-list, then the second value is
1023 ;;; T. If this returns a keyword symbol or a value from a rest arg,
1024 ;;; then the second value is NIL.
1026 ;;; FIXME: There's probably some way to merge the code here with
1027 ;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
1028 ;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)
1029 (declaim (ftype (function (index list)) nth-arg))
1030 (defun nth-arg (count args)
1032 (dolist (ele args (error "The argument specification ~S is out of range."
1034 (lambda-list-element-dispatch ele
1035 :required ((if (zerop n) (return (values ele t))))
1036 :optional ((if (zerop n) (return (values (second ele) t))))
1037 :keyword ((cond ((zerop n)
1038 (return (values (second ele) nil)))
1040 (return (values (third ele) t)))))
1041 :deleted ((if (zerop n) (return (values ele t))))
1042 :rest ((let ((var (second ele)))
1043 (lambda-var-dispatch var (sb!di:frame-code-location
1045 (error "unused &REST argument before n'th argument")
1047 (sb!di:debug-var-value var *current-frame*)
1049 "The argument specification ~S is out of range."
1052 (return-from nth-arg (values value nil))
1054 (error "invalid &REST argument before n'th argument")))))
1059 "Return the N'th argument's value if possible. Argument zero is the first
1060 argument in a frame's default printed representation. Count keyword/value
1061 pairs as separate arguments."
1062 (multiple-value-bind (var lambda-var-p)
1063 (nth-arg n (handler-case (sb!di:debug-fun-lambda-list
1064 (sb!di:frame-debug-fun *current-frame*))
1065 (sb!di:lambda-list-unavailable ()
1066 (error "No argument values are available."))))
1068 (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
1069 (error "Unused arguments have no values.")
1070 (sb!di:debug-var-value var *current-frame*)
1071 (error "invalid argument value"))
1074 ;;;; machinery for definition of debug loop commands
1076 (defvar *debug-commands* nil)
1078 ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
1080 (defmacro !def-debug-command (name args &rest body)
1081 (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
1083 (setf *debug-commands*
1084 (remove ,name *debug-commands* :key #'car :test #'string=))
1085 (defun ,fun-name ,args
1086 (unless *in-the-debugger*
1087 (error "invoking debugger command while outside the debugger"))
1089 (push (cons ,name #',fun-name) *debug-commands*)
1092 (defun !def-debug-command-alias (new-name existing-name)
1093 (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
1094 (unless pair (error "unknown debug command name: ~S" existing-name))
1095 (push (cons new-name (cdr pair)) *debug-commands*))
1098 ;;; This takes a symbol and uses its name to find a debugger command,
1099 ;;; using initial substring matching. It returns the command function
1100 ;;; if form identifies only one command, but if form is ambiguous,
1101 ;;; this returns a list of the command names. If there are no matches,
1102 ;;; this returns nil. Whenever the loop that looks for a set of
1103 ;;; possibilities encounters an exact name match, we return that
1104 ;;; command function immediately.
1105 (defun debug-command-p (form &optional other-commands)
1106 (if (or (symbolp form) (integerp form))
1110 (format nil "~W" form)))
1113 (declare (simple-string name)
1117 ;; Find matching commands, punting if exact match.
1118 (flet ((match-command (ele)
1119 (let* ((str (car ele))
1120 (str-len (length str)))
1121 (declare (simple-string str)
1123 (cond ((< str-len len))
1125 (when (string= name str :end1 len :end2 len)
1126 (return-from debug-command-p (cdr ele))))
1127 ((string= name str :end1 len :end2 len)
1129 (mapc #'match-command *debug-commands*)
1130 (mapc #'match-command other-commands))
1132 ;; Return the right value.
1133 (cond ((not res) nil)
1136 (t ; Just return the names.
1137 (do ((cmds res (cdr cmds)))
1139 (setf (car cmds) (caar cmds))))))))
1141 ;;; Return a list of debug commands (in the same format as
1142 ;;; *DEBUG-COMMANDS*) that invoke each active restart.
1144 ;;; Two commands are made for each restart: one for the number, and
1145 ;;; one for the restart name (unless it's been shadowed by an earlier
1146 ;;; restart of the same name, or it is NIL).
1147 (defun make-restart-commands (&optional (restarts *debug-restarts*))
1149 (num 0)) ; better be the same as show-restarts!
1150 (dolist (restart restarts)
1151 (let ((name (string (restart-name restart))))
1154 (/show0 "in restart-command closure, about to i-r-i")
1155 (invoke-restart-interactively restart))))
1156 (push (cons (prin1-to-string num) restart-fun) commands)
1157 (unless (or (null (restart-name restart))
1158 (find name commands :key #'car :test #'string=))
1159 (push (cons name restart-fun) commands))))
1163 ;;;; frame-changing commands
1165 (!def-debug-command "UP" ()
1166 (let ((next (sb!di:frame-up *current-frame*)))
1168 (setf *current-frame* next)
1169 (print-frame-call next *debug-io*))
1171 (format *debug-io* "~&Top of stack.")))))
1173 (!def-debug-command "DOWN" ()
1174 (let ((next (sb!di:frame-down *current-frame*)))
1176 (setf *current-frame* next)
1177 (print-frame-call next *debug-io*))
1179 (format *debug-io* "~&Bottom of stack.")))))
1181 (!def-debug-command-alias "D" "DOWN")
1183 (!def-debug-command "BOTTOM" ()
1184 (do ((prev *current-frame* lead)
1185 (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
1187 (setf *current-frame* prev)
1188 (print-frame-call prev *debug-io*))))
1190 (!def-debug-command-alias "B" "BOTTOM")
1192 (!def-debug-command "FRAME" (&optional
1193 (n (read-prompting-maybe "frame number: ")))
1194 (setf *current-frame*
1195 (multiple-value-bind (next-frame-fun limit-string)
1196 (if (< n (sb!di:frame-number *current-frame*))
1197 (values #'sb!di:frame-up "top")
1198 (values #'sb!di:frame-down "bottom"))
1199 (do ((frame *current-frame*))
1200 ((= n (sb!di:frame-number frame))
1202 (let ((next-frame (funcall next-frame-fun frame)))
1204 (setf frame next-frame))
1207 "The ~A of the stack was encountered.~%"
1209 (return frame)))))))
1210 (print-frame-call *current-frame* *debug-io*))
1212 (!def-debug-command-alias "F" "FRAME")
1214 ;;;; commands for entering and leaving the debugger
1216 (!def-debug-command "TOPLEVEL" ()
1217 (throw 'toplevel-catcher nil))
1220 (!def-debug-command-alias "TOP" "TOPLEVEL")
1222 (!def-debug-command "RESTART" ()
1223 (/show0 "doing RESTART debug-command")
1224 (let ((num (read-if-available :prompt)))
1225 (when (eq num :prompt)
1226 (show-restarts *debug-restarts* *debug-io*)
1227 (write-string "restart: " *debug-io*)
1228 (force-output *debug-io*)
1229 (setf num (read *debug-io*)))
1230 (let ((restart (typecase num
1232 (nth num *debug-restarts*))
1234 (find num *debug-restarts* :key #'restart-name
1235 :test (lambda (sym1 sym2)
1236 (string= (symbol-name sym1)
1237 (symbol-name sym2)))))
1239 (format *debug-io* "~S is invalid as a restart name.~%"
1241 (return-from restart-debug-command nil)))))
1242 (/show0 "got RESTART")
1244 (invoke-restart-interactively restart)
1245 (princ "There is no such restart." *debug-io*)))))
1247 ;;;; information commands
1249 (!def-debug-command "HELP" ()
1250 ;; CMU CL had a little toy pager here, but "if you aren't running
1251 ;; ILISP (or a smart windowing system, or something) you deserve to
1252 ;; lose", so we've dropped it in SBCL. However, in case some
1253 ;; desperate holdout is running this on a dumb terminal somewhere,
1254 ;; we tell him where to find the message stored as a string.
1256 "~&~A~2%(The HELP string is stored in ~S.)~%"
1258 '*debug-help-string*))
1260 (!def-debug-command-alias "?" "HELP")
1262 (!def-debug-command "ERROR" ()
1263 (format *debug-io* "~A~%" *debug-condition*)
1264 (show-restarts *debug-restarts* *debug-io*))
1266 (!def-debug-command "BACKTRACE" ()
1267 (backtrace (read-if-available most-positive-fixnum)))
1269 (!def-debug-command "PRINT" ()
1270 (print-frame-call *current-frame* *debug-io*))
1272 (!def-debug-command-alias "P" "PRINT")
1274 (!def-debug-command "LIST-LOCALS" ()
1275 (let ((d-fun (sb!di:frame-debug-fun *current-frame*)))
1276 (if (sb!di:debug-var-info-available d-fun)
1277 (let ((*standard-output* *debug-io*)
1278 (location (sb!di:frame-code-location *current-frame*))
1279 (prefix (read-if-available nil))
1284 (dolist (v (sb!di:ambiguous-debug-vars
1286 (if prefix (string prefix) "")))
1288 (when (eq (sb!di:debug-var-validity v location) :valid)
1289 (setf any-valid-p t)
1290 (case (sb!di::debug-var-info v)
1292 (setf more-context (sb!di:debug-var-value v *current-frame*)))
1294 (setf more-count (sb!di:debug-var-value v *current-frame*))))
1295 (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
1296 (sb!di:debug-var-symbol v)
1297 (zerop (sb!di:debug-var-id v))
1298 (sb!di:debug-var-id v)
1299 (sb!di:debug-var-value v *current-frame*))))
1300 (when (and more-context more-count)
1301 (format *debug-io* "~S = ~S~%"
1303 (multiple-value-list (sb!c:%more-arg-values more-context 0 more-count))))
1307 "There are no local variables ~@[starting with ~A ~]~
1312 "All variables ~@[starting with ~A ~]currently ~
1313 have invalid values."
1315 (write-line "There is no variable information available."
1318 (!def-debug-command-alias "L" "LIST-LOCALS")
1320 (!def-debug-command "SOURCE" ()
1321 (print (code-location-source-form (sb!di:frame-code-location *current-frame*)
1322 (read-if-available 0))
1325 ;;;; source location printing
1327 ;;; We cache a stream to the last valid file debug source so that we
1328 ;;; won't have to repeatedly open the file.
1330 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
1331 ;;; in the 1990s, so the benefit is negligible, less important than the
1332 ;;; potential of extra confusion if someone changes the source during
1333 ;;; a debug session and the change doesn't show up. And removing this
1334 ;;; would simplify the system, which I like. -- WHN 19990903
1335 (defvar *cached-debug-source* nil)
1336 (declaim (type (or sb!di:debug-source null) *cached-debug-source*))
1337 (defvar *cached-source-stream* nil)
1338 (declaim (type (or stream null) *cached-source-stream*))
1340 ;;; To suppress the read-time evaluation #. macro during source read,
1341 ;;; *READTABLE* is modified. *READTABLE* is cached to avoid
1342 ;;; copying it each time, and invalidated when the
1343 ;;; *CACHED-DEBUG-SOURCE* has changed.
1344 (defvar *cached-readtable* nil)
1345 (declaim (type (or readtable null) *cached-readtable*))
1347 ;;; Stuff to clean up before saving a core
1348 (defun debug-deinit ()
1349 (setf *cached-debug-source* nil
1350 *cached-source-stream* nil
1351 *cached-readtable* nil))
1353 ;;; We also cache the last toplevel form that we printed a source for
1354 ;;; so that we don't have to do repeated reads and calls to
1355 ;;; FORM-NUMBER-TRANSLATIONS.
1356 (defvar *cached-toplevel-form-offset* nil)
1357 (declaim (type (or index null) *cached-toplevel-form-offset*))
1358 (defvar *cached-toplevel-form*)
1359 (defvar *cached-form-number-translations*)
1361 ;;; Given a code location, return the associated form-number
1362 ;;; translations and the actual top level form. We check our cache ---
1363 ;;; if there is a miss, we dispatch on the kind of the debug source.
1364 (defun get-toplevel-form (location)
1365 (let ((d-source (sb!di:code-location-debug-source location)))
1366 (if (and (eq d-source *cached-debug-source*)
1367 (eql (sb!di:code-location-toplevel-form-offset location)
1368 *cached-toplevel-form-offset*))
1369 (values *cached-form-number-translations* *cached-toplevel-form*)
1370 (let* ((offset (sb!di:code-location-toplevel-form-offset location))
1372 (cond ((sb!di:debug-source-namestring d-source)
1373 (get-file-toplevel-form location))
1374 ((sb!di:debug-source-form d-source)
1375 (sb!di:debug-source-form d-source))
1376 (t (bug "Don't know how to use a DEBUG-SOURCE without ~
1377 a namestring or a form.")))))
1378 (setq *cached-toplevel-form-offset* offset)
1379 (values (setq *cached-form-number-translations*
1380 (sb!di:form-number-translations res offset))
1381 (setq *cached-toplevel-form* res))))))
1383 ;;; Locate the source file (if it still exists) and grab the top level
1384 ;;; form. If the file is modified, we use the top level form offset
1385 ;;; instead of the recorded character offset.
1386 (defun get-file-toplevel-form (location)
1387 (let* ((d-source (sb!di:code-location-debug-source location))
1388 (tlf-offset (sb!di:code-location-toplevel-form-offset location))
1389 (local-tlf-offset (- tlf-offset
1390 (sb!di:debug-source-root-number d-source)))
1392 (aref (or (sb!di:debug-source-start-positions d-source)
1393 (error "no start positions map"))
1395 (name (sb!di:debug-source-namestring d-source)))
1396 (unless (eq d-source *cached-debug-source*)
1397 (unless (and *cached-source-stream*
1398 (equal (pathname *cached-source-stream*)
1400 (setq *cached-readtable* nil)
1401 (when *cached-source-stream* (close *cached-source-stream*))
1402 (setq *cached-source-stream* (open name :if-does-not-exist nil))
1403 (unless *cached-source-stream*
1404 (error "The source file no longer exists:~% ~A" (namestring name)))
1405 (format *debug-io* "~%; file: ~A~%" (namestring name)))
1407 (setq *cached-debug-source*
1408 (if (= (sb!di:debug-source-created d-source)
1409 (file-write-date name))
1413 ((eq *cached-debug-source* d-source)
1414 (file-position *cached-source-stream* char-offset))
1417 "~%; File has been modified since compilation:~%; ~A~@
1418 ; Using form offset instead of character position.~%"
1420 (file-position *cached-source-stream* 0)
1421 (let ((*read-suppress* t))
1422 (dotimes (i local-tlf-offset)
1423 (read *cached-source-stream*)))))
1424 (unless *cached-readtable*
1425 (setq *cached-readtable* (copy-readtable))
1426 (set-dispatch-macro-character
1428 (lambda (stream sub-char &rest rest)
1429 (declare (ignore rest sub-char))
1430 (let ((token (read stream t nil t)))
1431 (format nil "#.~S" token)))
1432 *cached-readtable*))
1433 (let ((*readtable* *cached-readtable*))
1434 (read *cached-source-stream*))))
1436 (defun code-location-source-form (location context)
1437 (let* ((location (maybe-block-start-location location))
1438 (form-num (sb!di:code-location-form-number location)))
1439 (multiple-value-bind (translations form) (get-toplevel-form location)
1440 (unless (< form-num (length translations))
1441 (error "The source path no longer exists."))
1442 (sb!di:source-path-context form
1443 (svref translations form-num)
1447 ;;; start single-stepping
1448 (!def-debug-command "START" ()
1449 (if (typep *debug-condition* 'step-condition)
1450 (format *debug-io* "~&Already single-stepping.~%")
1451 (let ((restart (find-restart 'continue *debug-condition*)))
1453 (sb!impl::enable-stepping)
1454 (invoke-restart restart))
1456 (format *debug-io* "~&Non-continuable error, cannot start stepping.~%"))))))
1458 (defmacro def-step-command (command-name restart-name)
1459 `(!def-debug-command ,command-name ()
1460 (if (typep *debug-condition* 'step-condition)
1461 (let ((restart (find-restart ',restart-name *debug-condition*)))
1463 (invoke-restart restart))
1464 (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))))
1466 (def-step-command "STEP" step-into)
1467 (def-step-command "NEXT" step-next)
1468 (def-step-command "STOP" step-continue)
1470 (!def-debug-command-alias "S" "STEP")
1471 (!def-debug-command-alias "N" "NEXT")
1473 (!def-debug-command "OUT" ()
1474 (if (typep *debug-condition* 'step-condition)
1475 (if sb!impl::*step-out*
1476 (let ((restart (find-restart 'step-out *debug-condition*)))
1478 (invoke-restart restart))
1479 (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%"))
1480 (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))
1482 ;;; miscellaneous commands
1484 (!def-debug-command "DESCRIBE" ()
1485 (let* ((curloc (sb!di:frame-code-location *current-frame*))
1486 (debug-fun (sb!di:code-location-debug-fun curloc))
1487 (function (sb!di:debug-fun-fun debug-fun)))
1490 (format *debug-io* "can't figure out the function for this frame"))))
1492 (!def-debug-command "SLURP" ()
1493 (loop while (read-char-no-hang *standard-input*)))
1495 ;;; RETURN-FROM-FRAME and RESTART-FRAME
1497 (defun unwind-to-frame-and-call (frame thunk)
1498 #!+unwind-to-frame-and-call-vop
1499 (flet ((sap-int/fixnum (sap)
1500 ;; On unithreaded X86 *BINDING-STACK-POINTER* and
1501 ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through
1502 ;; some hoops to make these calculated values negative too.
1503 (ash (truly-the (signed-byte #.sb!vm:n-word-bits)
1505 (- sb!vm::n-fixnum-tag-bits))))
1506 ;; To properly unwind the stack, we need three pieces of information:
1507 ;; * The unwind block that should be active after the unwind
1508 ;; * The catch block that should be active after the unwind
1509 ;; * The values that the binding stack pointer should have after the
1511 (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame)))
1512 (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame))))
1513 ;; This VOP will run the neccessary cleanup forms, reset the fp, and
1514 ;; then call the supplied function.
1515 (sb!vm::%primitive sb!vm::unwind-to-frame-and-call
1516 (sb!di::frame-pointer frame)
1517 (find-enclosing-uwp frame)
1519 ;; Before calling the user-specified
1520 ;; function, we need to restore the binding
1521 ;; stack and the catch block. The unwind block
1522 ;; is taken care of by the VOP.
1523 (sb!vm::%primitive sb!vm::unbind-to-here
1525 (setf sb!vm::*current-catch-block* block)
1527 #!-unwind-to-frame-and-call-vop
1528 (let ((tag (gensym)))
1529 (sb!di:replace-frame-catch-tag frame
1530 'sb!c:debug-catch-tag
1534 (defun find-binding-stack-pointer (frame)
1535 #!-stack-grows-downward-not-upward
1536 (declare (ignore frame))
1537 #!-stack-grows-downward-not-upward
1538 (error "Not implemented on this architecture")
1539 #!+stack-grows-downward-not-upward
1540 (let ((bsp (sb!vm::binding-stack-pointer-sap))
1542 (fp (sb!di::frame-pointer frame))
1543 (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1544 (ash sb!vm:*binding-stack-start*
1545 sb!vm:n-fixnum-tag-bits)))))
1546 ;; Walk the binding stack looking for an entry where the symbol is
1547 ;; an unbound-symbol marker and the value is equal to the frame
1548 ;; pointer. These entries are inserted into the stack by the
1549 ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into
1550 ;; the function during IR2). If an entry wasn't found, the
1551 ;; function that the frame corresponds to wasn't compiled with a
1552 ;; high enough debug setting, and can't be restarted / returned
1554 (loop until (sap= bsp start)
1557 (- (* sb!vm:binding-size sb!vm:n-word-bytes))))
1558 (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot
1559 sb!vm:n-word-bytes)))
1560 (value (sap-ref-sap bsp (* sb!vm:binding-value-slot
1561 sb!vm:n-word-bytes))))
1562 (when (eql symbol sb!vm:unbound-marker-widetag)
1563 (when (sap= value fp)
1564 (setf unbind-to bsp))))))
1567 (defun find-enclosing-catch-block (frame)
1568 ;; Walk the catch block chain looking for the first entry with an address
1569 ;; higher than the pointer for FRAME or a null pointer.
1570 (let* ((frame-pointer (sb!di::frame-pointer frame))
1571 (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1572 (ash sb!vm::*current-catch-block*
1573 sb!vm:n-fixnum-tag-bits))))
1574 (enclosing-block (loop for block = current-block
1575 then (sap-ref-sap block
1576 (* sb!vm:catch-block-previous-catch-slot
1577 sb!vm::n-word-bytes))
1578 when (or (zerop (sap-int block))
1579 (sap> block frame-pointer))
1583 (defun find-enclosing-uwp (frame)
1584 ;; Walk the UWP chain looking for the first entry with an address
1585 ;; higher than the pointer for FRAME or a null pointer.
1586 (let* ((frame-pointer (sb!di::frame-pointer frame))
1587 (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1588 (ash sb!vm::*current-unwind-protect-block*
1589 sb!vm:n-fixnum-tag-bits))))
1590 (enclosing-uwp (loop for uwp-block = current-uwp
1591 then (sap-ref-sap uwp-block
1592 sb!vm:unwind-block-current-uwp-slot)
1593 when (or (zerop (sap-int uwp-block))
1594 (sap> uwp-block frame-pointer))
1598 (!def-debug-command "RETURN" (&optional
1599 (return (read-prompting-maybe
1601 (if (frame-has-debug-tag-p *current-frame*)
1602 (let* ((code-location (sb!di:frame-code-location *current-frame*))
1603 (values (multiple-value-list
1604 (funcall (sb!di:preprocess-for-eval return code-location)
1606 (unwind-to-frame-and-call *current-frame* (lambda ()
1607 (values-list values))))
1609 "~@<can't find a tag for this frame ~
1610 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1611 and recompiling)~:@>")))
1613 (!def-debug-command "RESTART-FRAME" ()
1614 (if (frame-has-debug-tag-p *current-frame*)
1615 (multiple-value-bind (fname args) (frame-call *current-frame*)
1616 (multiple-value-bind (fun arglist ok)
1617 (if (and (legal-fun-name-p fname) (fboundp fname))
1618 (values (fdefinition fname) args t)
1619 (values (sb!di:debug-fun-fun (sb!di:frame-debug-fun *current-frame*))
1620 (frame-args-as-list *current-frame*)
1624 (y-or-n-p "~@<No global function for the frame, but we ~
1625 do have access to a function object that we ~
1626 can try to call -- but if it is normally part ~
1627 of a closure, then this is NOT going to end well.~_~_~
1628 Try it anyways?~:@>")))
1629 (unwind-to-frame-and-call *current-frame*
1632 (declare (optimize (debug 0)))
1633 (apply fun arglist))))
1635 "Can't restart ~S: no function for frame."
1638 "~@<Can't restart ~S: tag not found. ~
1639 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1640 and recompiling)~:@>"
1643 (defun frame-has-debug-tag-p (frame)
1644 #!+unwind-to-frame-and-call-vop
1645 (not (null (find-binding-stack-pointer frame)))
1646 #!-unwind-to-frame-and-call-vop
1647 (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car))
1649 (defun frame-has-debug-vars-p (frame)
1650 (sb!di:debug-var-info-available
1651 (sb!di:code-location-debug-fun
1652 (sb!di:frame-code-location frame))))
1654 ;; Hack: ensure that *U-T-F-F* has a tls index.
1655 #!+unwind-to-frame-and-call-vop
1656 (let ((sb!vm::*unwind-to-frame-function* (lambda ()))))
1659 ;;;; debug loop command utilities
1661 (defun read-prompting-maybe (prompt)
1662 (unless (sb!int:listen-skip-whitespace *debug-io*)
1663 (princ prompt *debug-io*)
1664 (force-output *debug-io*))
1667 (defun read-if-available (default)
1668 (if (sb!int:listen-skip-whitespace *debug-io*)