Merge branch 'master' of git://repo.or.cz/sbcl
[sbcl/attila.git] / src / code / debug.lisp
blob3d75a49abe152964aa6882faf048d258d7dbe1ff
1 ;;;; the debugger
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
30 ;;; #
31 ;;; to satisfy lambda list
32 ;;; #:
33 ;;; exactly 2 expected, but 5 found
34 (defvar *debug-print-variable-alist* nil
35 #!+sb-doc
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
54 nil
55 #!+sb-doc
56 "*READTABLE* for the debugger")
58 (defvar *in-the-debugger* nil
59 #!+sb-doc
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)
83 (format stream
84 "~%~W~:[~;[~W~]] "
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
101 to debugger.
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
110 that restart.
112 Changing frames:
113 UP up frame DOWN down frame
114 BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
116 Inspecting frames:
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.
122 Stepping:
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:
133 (SB-DEBUG:ARG n)
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.
138 Other commands:
139 RETURN expr
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.
144 RESTART-FRAME
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.
149 SLURP
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)
162 (return loc))))
163 (cond ((and (not (sb!di:debug-block-elsewhere-p block))
164 start)
165 (format *debug-io* "~%unknown location: using block start~%")
166 start)
168 loc)))
169 loc))
171 ;;;; BACKTRACE
173 (defun backtrace (&optional (count most-positive-fixnum) (stream *debug-io*))
174 #!+sb-doc
175 "Show a listing of the call stack going down from the current frame.
176 In the debugger, the current frame is indicated by the prompt. COUNT
177 is how many frames to show."
178 (fresh-line stream)
179 (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
180 (sb!di:frame-down frame))
181 (count count (1- count)))
182 ((or (null frame) (zerop count)))
183 (print-frame-call frame stream :number t))
184 (fresh-line stream)
185 (values))
187 (defun backtrace-as-list (&optional (count most-positive-fixnum))
188 #!+sb-doc "Return a list representing the current BACKTRACE."
189 (do ((reversed-result nil)
190 (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
191 (sb!di:frame-down frame))
192 (count count (1- count)))
193 ((or (null frame) (zerop count))
194 (nreverse reversed-result))
195 (push (frame-call-as-list frame) reversed-result)))
197 (defun frame-call-as-list (frame)
198 (multiple-value-bind (name args) (frame-call frame)
199 (cons name args)))
201 ;;;; frame printing
203 (eval-when (:compile-toplevel :execute)
205 ;;; This is a convenient way to express what to do for each type of
206 ;;; lambda-list element.
207 (sb!xc:defmacro lambda-list-element-dispatch (element
208 &key
209 required
210 optional
211 rest
212 keyword
213 deleted)
214 `(etypecase ,element
215 (sb!di:debug-var
216 ,@required)
217 (cons
218 (ecase (car ,element)
219 (:optional ,@optional)
220 (:rest ,@rest)
221 (:keyword ,@keyword)))
222 (symbol
223 (aver (eq ,element :deleted))
224 ,@deleted)))
226 (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
227 (let ((var (gensym)))
228 `(let ((,var ,variable))
229 (cond ((eq ,var :deleted) ,deleted)
230 ((eq (sb!di:debug-var-validity ,var ,location) :valid)
231 ,valid)
232 (t ,other)))))
234 ) ; EVAL-WHEN
236 ;;; Extract the function argument values for a debug frame.
237 (defun frame-args-as-list (frame)
238 (let ((debug-fun (sb!di:frame-debug-fun frame))
239 (loc (sb!di:frame-code-location frame))
240 (reversed-result nil))
241 (handler-case
242 (progn
243 (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
244 (lambda-list-element-dispatch ele
245 :required ((push (frame-call-arg ele loc frame) reversed-result))
246 :optional ((push (frame-call-arg (second ele) loc frame)
247 reversed-result))
248 :keyword ((push (second ele) reversed-result)
249 (push (frame-call-arg (third ele) loc frame)
250 reversed-result))
251 :deleted ((push (frame-call-arg ele loc frame) reversed-result))
252 :rest ((lambda-var-dispatch (second ele) loc
254 (progn
255 (setf reversed-result
256 (append (reverse (sb!di:debug-var-value
257 (second ele) frame))
258 reversed-result))
259 (return))
260 (push (make-unprintable-object
261 "unavailable &REST argument")
262 reversed-result)))))
263 ;; As long as we do an ordinary return (as opposed to SIGNALing
264 ;; a CONDITION) from the DOLIST above:
265 (nreverse reversed-result))
266 (sb!di:lambda-list-unavailable
268 (make-unprintable-object "unavailable lambda list")))))
270 (defvar *verbosity* 1)
272 (defun clean-xep (name args)
273 (values (or (and (consp name)
274 (second name))
275 name)
276 (if (consp args)
277 (let ((count (first args))
278 (real-args (rest args)))
279 (if (fixnump count)
280 (subseq real-args 0
281 (min count (length real-args)))
282 real-args))
283 args)))
285 (defun clean-&more-processor (name args)
286 (values (or (and (consp name)
287 (second name))
288 name)
289 (if (consp args)
290 (let* ((more (last args 2))
291 (context (first more))
292 (count (second more)))
293 (append
294 (butlast args 2)
295 (if (fixnump count)
296 (multiple-value-list
297 (sb!c:%more-arg-values context 0 count))
298 (list
299 (make-unprintable-object "more unavailable arguments")))))
300 args)))
302 ;; Cleaning sb-pcl::fast-method is a bit different then other cleanings in that
303 ;; sb-pcl::fast-method is actually part of the method name. But it makes the
304 ;; backtrace less readable, so we do it on (< verbosity 2)
305 (defun clean-fast-method (name args)
306 (values (or (and (consp name)
307 (rest name))
308 name)
309 (if (and (consp args)
310 (consp name))
311 (let ((last (car (last name))))
312 (or (and (consp last)
313 ;; safely get the length of the lambda-list and the last
314 ;; n args are the actual args of the function call
315 (loop for cell = last :then (cdr cell)
316 while cell
317 unless (consp cell) do (return nil)
318 count 1 :into arg-count
319 finally (return (last args arg-count))))
320 args))
321 args)))
323 (defun frame-call (frame &key (verbosity *verbosity*))
324 (let* ((*verbosity* verbosity)
325 (debug-fun (sb!di:frame-debug-fun frame))
326 (name (sb!di:debug-fun-name debug-fun))
327 (args (frame-args-as-list frame)))
328 (labels ((clean-name-and-args (name args)
329 (if (consp name)
330 ;; FIXME: do we need to deal with
331 ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
332 ;; &AUX-BINDINGS appear in backtraces, so they are
333 ;; left alone for now. --NS 2005-02-28
334 (case (first name)
335 ((sb!c::xep sb!c::tl-xep)
336 (clean-xep name args))
337 ((sb!c::&more-processor)
338 (clean-&more-processor name args))
339 ((sb!pcl::fast-method)
340 (if (< verbosity 2)
341 (clean-fast-method name args)
342 (values name args)))
343 ((sb!c::hairy-arg-processor
344 sb!c::varargs-entry sb!c::&optional-processor)
345 (clean-name-and-args (second name) args))
346 (t (values name args)))
347 (values name args))))
348 (unless (>= *verbosity* 2)
349 (loop named cleaning do
350 (progn
351 (multiple-value-bind (new-name new-args)
352 (clean-name-and-args name args)
353 (when (or (not new-name)
354 (and (eq new-name name)
355 (eq new-args args)))
356 (return-from cleaning))
357 (setf name new-name
358 args new-args)))))
359 (values name args (sb!di:debug-fun-kind debug-fun)))))
361 (defun ensure-printable-object (object)
362 (handler-case
363 (with-open-stream (out (make-broadcast-stream))
364 (prin1 object out)
365 object)
366 (error (cond)
367 (declare (ignore cond))
368 (make-unprintable-object "error printing object"))))
370 (defun frame-call-arg (var location frame)
371 (lambda-var-dispatch var location
372 (make-unprintable-object "unused argument")
373 (sb!di:debug-var-value var frame)
374 (make-unprintable-object "unavailable argument")))
376 ;;; Prints a representation of the function call causing FRAME to
377 ;;; exist. VERBOSITY indicates the level of information to output;
378 ;;; zero indicates just printing the DEBUG-FUN's name, and one
379 ;;; indicates displaying call-like, one-liner format with argument
380 ;;; values.
381 (defun print-frame-call (frame stream &key (verbosity *verbosity*) (number nil))
382 (let ((*verbosity* verbosity))
383 (when number
384 (format stream "~&~S: " (sb!di:frame-number frame)))
385 (if (zerop *verbosity*)
386 (let ((*print-readably* nil))
387 (prin1 frame stream))
388 (multiple-value-bind (name args kind)
389 (frame-call frame)
390 (pprint-logical-block (stream nil :prefix "(" :suffix ")")
391 ;; Since we go to some trouble to make nice informative function
392 ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
393 ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
394 ;; For the function arguments, we can just print normally.
395 (let ((*print-length* nil)
396 (*print-level* nil))
397 (prin1 (ensure-printable-object name) stream))
398 ;; If we hit a &REST arg, then print as many of the values as
399 ;; possible, punting the loop over lambda-list variables since any
400 ;; other arguments will be in the &REST arg's list of values.
401 (let ((args (ensure-printable-object args)))
402 (if (listp args)
403 (format stream "~{ ~_~S~}" args)
404 (format stream " ~S" args))))
405 (when (and kind (> *verbosity* 1))
406 (format stream " [~S]" kind))))
407 (when (>= *verbosity* 2)
408 (let ((loc (sb!di:frame-code-location frame)))
409 (handler-case
410 (progn
411 ;; FIXME: Is this call really necessary here? If it is,
412 ;; then the reason for it should be unobscured.
413 (sb!di:code-location-debug-block loc)
414 (format stream "~%source: ")
415 (prin1 (code-location-source-form loc 0) stream))
416 (sb!di:debug-condition (ignore)
417 ignore)
418 (error (c)
419 (format stream "~&error finding source: ~A" c)))))))
421 ;;;; INVOKE-DEBUGGER
423 (defvar *debugger-hook* nil
424 #!+sb-doc
425 "This is either NIL or a function of two arguments, a condition and the value
426 of *DEBUGGER-HOOK*. This function can either handle the condition or return
427 which causes the standard debugger to execute. The system passes the value
428 of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
429 around the invocation.")
431 (defvar *invoke-debugger-hook* nil
432 #!+sb-doc
433 "This is either NIL or a designator for a function of two arguments,
434 to be run when the debugger is about to be entered. The function is
435 run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
436 errors, and receives as arguments the condition that triggered
437 debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
439 This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
440 In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
441 called by BREAK.")
443 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
444 (defvar *debug-restarts*)
445 (defvar *debug-condition*)
446 (defvar *nested-debug-condition*)
448 ;;; Oh, what a tangled web we weave when we preserve backwards
449 ;;; compatibility with 1968-style use of global variables to control
450 ;;; per-stream i/o properties; there's really no way to get this
451 ;;; quite right, but we do what we can.
452 (defun funcall-with-debug-io-syntax (fun &rest rest)
453 (declare (type function fun))
454 ;; Try to force the other special variables into a useful state.
455 (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
456 ;; any default we might use is less useful than just reusing
457 ;; the global values.
458 (original-package *package*)
459 (original-print-pretty *print-pretty*)
460 (original-print-right-margin *print-right-margin*))
461 (with-standard-io-syntax
462 (with-sane-io-syntax
463 (let (;; We want the printer and reader to be in a useful
464 ;; state, regardless of where the debugger was invoked
465 ;; in the program. WITH-STANDARD-IO-SYNTAX and
466 ;; WITH-SANE-IO-SYNTAX do much of what we want, but
467 ;; * It doesn't affect our internal special variables
468 ;; like *CURRENT-LEVEL-IN-PRINT*.
469 ;; * It isn't customizable.
470 ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not
471 ;; helpful behavior for a debugger.
472 ;; * There's no particularly good debugger default for
473 ;; *PRINT-PRETTY*, since T is usually what you want
474 ;; -- except absolutely not what you want when you're
475 ;; debugging failures in PRINT-OBJECT logic.
476 ;; We try to address all these issues with explicit
477 ;; rebindings here.
478 (sb!kernel:*current-level-in-print* 0)
479 (*package* original-package)
480 (*print-right-margin* original-print-right-margin)
481 (*print-pretty* original-print-pretty)
482 ;; Clear the circularity machinery to try to to reduce the
483 ;; pain from sharing the circularity table across all
484 ;; streams; if these are not rebound here, then setting
485 ;; *PRINT-CIRCLE* within the debugger when debugging in a
486 ;; state where something circular was being printed (e.g.,
487 ;; because the debugger was entered on an error in a
488 ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
489 ;; here does seem somewhat ugly because it makes it more
490 ;; difficult to debug the printing-of-circularities code
491 ;; itself; however, as far as I (WHN, 2004-05-29) can see,
492 ;; that's almost entirely academic as long as there's one
493 ;; shared *C-H-T* for all streams (i.e., it's already
494 ;; unreasonably difficult to debug print-circle machinery
495 ;; given the buggy crosstalk between the debugger streams
496 ;; and the stream you're trying to watch), and any fix for
497 ;; that buggy arrangement will likely let this hack go away
498 ;; naturally.
499 (sb!impl::*circularity-hash-table* . nil)
500 (sb!impl::*circularity-counter* . nil)
501 (*readtable* *debug-readtable*))
502 (progv
503 ;; (Why NREVERSE? PROGV makes the later entries have
504 ;; precedence over the earlier entries.
505 ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
506 ;; expected that its earlier entries have precedence. And
507 ;; the earlier-has-precedence behavior is mostly more
508 ;; convenient, so that programmers can use PUSH or LIST* to
509 ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
510 (nreverse (mapcar #'car *debug-print-variable-alist*))
511 (nreverse (mapcar #'cdr *debug-print-variable-alist*))
512 (apply fun rest)))))))
514 (defun invoke-debugger (condition)
515 #!+sb-doc
516 "Enter the debugger."
518 ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
519 ;; called when the debugger is disabled
520 (let ((old-hook *invoke-debugger-hook*))
521 (when old-hook
522 (let ((*invoke-debugger-hook* nil))
523 (funcall old-hook condition old-hook))))
524 (let ((old-hook *debugger-hook*))
525 (when old-hook
526 (let ((*debugger-hook* nil))
527 (funcall old-hook condition old-hook))))
529 ;; We definitely want *PACKAGE* to be of valid type.
531 ;; Elsewhere in the system, we use the SANE-PACKAGE function for
532 ;; this, but here causing an exception just as we're trying to handle
533 ;; an exception would be confusing, so instead we use a special hack.
534 (unless (and (packagep *package*)
535 (package-name *package*))
536 (setf *package* (find-package :cl-user))
537 (format *error-output*
538 "The value of ~S was not an undeleted PACKAGE. It has been
539 reset to ~S."
540 '*package* *package*))
542 ;; Before we start our own output, finish any pending output.
543 ;; Otherwise, if the user tried to track the progress of his program
544 ;; using PRINT statements, he'd tend to lose the last line of output
545 ;; or so, which'd be confusing.
546 (flush-standard-output-streams)
548 (funcall-with-debug-io-syntax #'%invoke-debugger condition))
550 (defun %print-debugger-invocation-reason (condition stream)
551 (format stream "~2&")
552 ;; Note: Ordinarily it's only a matter of taste whether to use
553 ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
554 ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
555 ;; definitely preferred, because the FORMAT alternative was acting odd.
556 (pprint-logical-block (stream nil)
557 (format stream
558 "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A"
559 (type-of condition)
560 #!+sb-thread sb!thread:*current-thread*
561 #!-sb-thread nil
562 condition))
563 (terpri stream))
565 (defun %invoke-debugger (condition)
566 (let ((*debug-condition* condition)
567 (*debug-restarts* (compute-restarts condition))
568 (*nested-debug-condition* nil))
569 (handler-case
570 ;; (The initial output here goes to *ERROR-OUTPUT*, because the
571 ;; initial output is not interactive, just an error message, and
572 ;; when people redirect *ERROR-OUTPUT*, they could reasonably
573 ;; expect to see error messages logged there, regardless of what
574 ;; the debugger does afterwards.)
575 (unless (typep condition 'step-condition)
576 (%print-debugger-invocation-reason condition *error-output*))
577 (error (condition)
578 (setf *nested-debug-condition* condition)
579 (let ((ndc-type (type-of *nested-debug-condition*)))
580 (format *error-output*
581 "~&~@<(A ~S was caught when trying to print ~S when ~
582 entering the debugger. Printing was aborted and the ~
583 ~S was stored in ~S.)~@:>~%"
584 ndc-type
585 '*debug-condition*
586 ndc-type
587 '*nested-debug-condition*))
588 (when (typep *nested-debug-condition* 'cell-error)
589 ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
590 (format *error-output*
591 "~&(CELL-ERROR-NAME ~S) = ~S~%"
592 '*nested-debug-condition*
593 (cell-error-name *nested-debug-condition*)))))
595 (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
596 *debug-io*)))
598 ;; After the initial error/condition/whatever announcement to
599 ;; *ERROR-OUTPUT*, we become interactive, and should talk on
600 ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
601 ;; statement, not a description of reality.:-| There's a lot of
602 ;; older debugger code which was written to do i/o on whatever
603 ;; stream was in fashion at the time, and not all of it has
604 ;; been converted to behave this way. -- WHN 2000-11-16)
606 (unwind-protect
607 (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
608 ;; here as well, but that is probably bogus since it
609 ;; removes the users ability to do output to a redirected
610 ;; *S-O*. Now we just rebind it so that users can temporarily
611 ;; frob it. FIXME: This and other "what gets bound when"
612 ;; behaviour should be documented in the manual.
613 (*standard-output* *standard-output*)
614 ;; This seems reasonable: e.g. if the user has redirected
615 ;; *ERROR-OUTPUT* to some log file, it's probably wrong
616 ;; to send errors which occur in interactive debugging to
617 ;; that file, and right to send them to *DEBUG-IO*.
618 (*error-output* *debug-io*))
619 (unless (typep condition 'step-condition)
620 (when *debug-beginner-help-p*
621 (format *debug-io*
622 "~%~@<Type HELP for debugger help, or ~
623 (SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
624 (show-restarts *debug-restarts* *debug-io*))
625 (internal-debug))
626 (when background-p
627 (sb!thread::release-foreground))))))
629 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
630 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
631 ;;; command-line option
632 (defun debugger-disabled-hook (condition me)
633 (declare (ignore me))
634 ;; There is no one there to interact with, so report the
635 ;; condition and terminate the program.
636 (flet ((failure-quit (&key recklessly-p)
637 (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
638 (quit :unix-status 1 :recklessly-p recklessly-p)))
639 ;; This HANDLER-CASE is here mostly to stop output immediately
640 ;; (and fall through to QUIT) when there's an I/O error. Thus,
641 ;; when we're run under a shell script or something, we can die
642 ;; cleanly when the script dies (and our pipes are cut), instead
643 ;; of falling into ldb or something messy like that. Similarly, we
644 ;; can terminate cleanly even if BACKTRACE dies because of bugs in
645 ;; user PRINT-OBJECT methods.
646 (handler-case
647 (progn
648 (format *error-output*
649 "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
650 (type-of condition)
651 #!+sb-thread sb!thread:*current-thread*
652 #!-sb-thread nil
653 condition)
654 ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
655 ;; even if we hit an error within BACKTRACE (e.g. a bug in
656 ;; the debugger's own frame-walking code, or a bug in a user
657 ;; PRINT-OBJECT method) we'll at least have the CONDITION
658 ;; printed out before we die.
659 (finish-output *error-output*)
660 ;; (Where to truncate the BACKTRACE is of course arbitrary, but
661 ;; it seems as though we should at least truncate it somewhere.)
662 (sb!debug:backtrace 128 *error-output*)
663 (format
664 *error-output*
665 "~%unhandled condition in --disable-debugger mode, quitting~%")
666 (finish-output *error-output*)
667 (failure-quit))
668 (condition ()
669 ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
670 ;; fail when our output streams are blown away, as e.g. when
671 ;; we're running under a Unix shell script and it dies somehow
672 ;; (e.g. because of a SIGINT). In that case, we might as well
673 ;; just give it up for a bad job, and stop trying to notify
674 ;; the user of anything.
676 ;; Actually, the only way I've run across to exercise the
677 ;; problem is to have more than one layer of shell script.
678 ;; I have a shell script which does
679 ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
680 ;; and the problem occurs when I interrupt this with Ctrl-C
681 ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
682 ;; I haven't figured out whether it's bash, time, tee, Linux, or
683 ;; what that is responsible, but that it's possible at all
684 ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
685 (ignore-errors
686 (%primitive print
687 "Argh! error within --disable-debugger error handling"))
688 (failure-quit :recklessly-p t)))))
690 (defvar *old-debugger-hook* nil)
692 ;;; halt-on-failures and prompt-on-failures modes, suitable for
693 ;;; noninteractive and interactive use respectively
694 (defun disable-debugger ()
695 ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
696 ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
697 ;; to set it to a suitable value again and be very careful,
698 ;; especially if the user has also set it. -- MG 2005-07-15
699 (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
700 (setf *old-debugger-hook* *invoke-debugger-hook*
701 *invoke-debugger-hook* 'debugger-disabled-hook))
702 ;; This is not inside the UNLESS to ensure that LDB is disabled
703 ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
704 ;; This might matter for example when restoring a core.
705 (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
706 (function sb!alien:void))))
708 (defun enable-debugger ()
709 (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
710 (setf *invoke-debugger-hook* *old-debugger-hook*
711 *old-debugger-hook* nil))
712 (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler"
713 (function sb!alien:void))))
715 (defun show-restarts (restarts s)
716 (cond ((null restarts)
717 (format s
718 "~&(no restarts: If you didn't do this on purpose, ~
719 please report it as a bug.)~%"))
721 (format s "~&restarts (invokable by number or by ~
722 possibly-abbreviated name):~%")
723 (let ((count 0)
724 (names-used '(nil))
725 (max-name-len 0))
726 (dolist (restart restarts)
727 (let ((name (restart-name restart)))
728 (when name
729 (let ((len (length (princ-to-string name))))
730 (when (> len max-name-len)
731 (setf max-name-len len))))))
732 (unless (zerop max-name-len)
733 (incf max-name-len 3))
734 (dolist (restart restarts)
735 (let ((name (restart-name restart)))
736 ;; FIXME: maybe it would be better to display later names
737 ;; in parens instead of brakets, not just omit them fully.
738 ;; Call BREAK, call BREAK in the debugger, and tell me
739 ;; it's not confusing looking. --NS 20050310
740 (cond ((member name names-used)
741 (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
743 (format s "~& ~2D: [~VA] ~A~%"
744 count (- max-name-len 3) name restart)
745 (push name names-used))))
746 (incf count))))))
748 (defvar *debug-loop-fun* #'debug-loop-fun
749 "a function taking no parameters that starts the low-level debug loop")
751 ;;; When the debugger is invoked due to a stepper condition, we don't
752 ;;; want to print the current frame before the first prompt for aesthetic
753 ;;; reasons.
754 (defvar *suppress-frame-print* nil)
756 ;;; This calls DEBUG-LOOP, performing some simple initializations
757 ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
758 ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
759 ;;; to get into a debug prompt as quickly as possible with as little
760 ;;; risk as possible for stepping on whatever is causing recursive
761 ;;; errors.
762 (defun internal-debug ()
763 (let ((*in-the-debugger* t)
764 (*read-suppress* nil))
765 (unless (typep *debug-condition* 'step-condition)
766 (clear-input *debug-io*))
767 (let ((*suppress-frame-print* (typep *debug-condition* 'step-condition)))
768 (funcall *debug-loop-fun*))))
770 ;;;; DEBUG-LOOP
772 ;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
773 ;;; was motivated by desire to play nicely with ILISP.
774 (defvar *flush-debug-errors* nil
775 #!+sb-doc
776 "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
777 executing in the debugger.")
779 (defun debug-read (stream)
780 (declare (type stream stream))
781 (let* ((eof-marker (cons nil nil))
782 (form (read stream nil eof-marker)))
783 (if (eq form eof-marker)
784 (abort)
785 form)))
787 (defun debug-loop-fun ()
788 (let* ((*debug-command-level* (1+ *debug-command-level*))
789 (*real-stack-top* (sb!di:top-frame))
790 (*stack-top* (or *stack-top-hint* *real-stack-top*))
791 (*stack-top-hint* nil)
792 (*current-frame* *stack-top*))
793 (handler-bind ((sb!di:debug-condition
794 (lambda (condition)
795 (princ condition *debug-io*)
796 (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
797 (throw 'debug-loop-catcher nil))))
798 (cond (*suppress-frame-print*
799 (setf *suppress-frame-print* nil))
801 (terpri *debug-io*)
802 (print-frame-call *current-frame* *debug-io*)))
803 (loop
804 (catch 'debug-loop-catcher
805 (handler-bind ((error (lambda (condition)
806 (when *flush-debug-errors*
807 (clear-input *debug-io*)
808 (princ condition *debug-io*)
809 (format *debug-io*
810 "~&error flushed (because ~
811 ~S is set)"
812 '*flush-debug-errors*)
813 (/show0 "throwing DEBUG-LOOP-CATCHER")
814 (throw 'debug-loop-catcher nil)))))
815 ;; We have to bind LEVEL for the restart function created by
816 ;; WITH-SIMPLE-RESTART.
817 (let ((level *debug-command-level*)
818 (restart-commands (make-restart-commands)))
819 (flush-standard-output-streams)
820 (debug-prompt *debug-io*)
821 (force-output *debug-io*)
822 (let* ((exp (debug-read *debug-io*))
823 (cmd-fun (debug-command-p exp restart-commands)))
824 (with-simple-restart (abort
825 "~@<Reduce debugger level (to debug level ~W).~@:>"
826 level)
827 (cond ((not cmd-fun)
828 (debug-eval-print exp))
829 ((consp cmd-fun)
830 (format *debug-io*
831 "~&Your command, ~S, is ambiguous:~%"
832 exp)
833 (dolist (ele cmd-fun)
834 (format *debug-io* " ~A~%" ele)))
836 (funcall cmd-fun))))))))))))
838 (defun debug-eval-print (expr)
839 (/noshow "entering DEBUG-EVAL-PRINT" expr)
840 (let ((values (multiple-value-list (interactive-eval expr))))
841 (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
842 (dolist (value values)
843 (fresh-line *debug-io*)
844 (prin1 value *debug-io*)))
845 (force-output *debug-io*))
847 ;;;; debug loop functions
849 ;;; These commands are functions, not really commands, so that users
850 ;;; can get their hands on the values returned.
852 (eval-when (:execute :compile-toplevel)
854 (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
855 `(let* ((temp (etypecase name
856 (symbol (sb!di:debug-fun-symbol-vars
857 (sb!di:frame-debug-fun *current-frame*)
858 name))
859 (simple-string (sb!di:ambiguous-debug-vars
860 (sb!di:frame-debug-fun *current-frame*)
861 name))))
862 (location (sb!di:frame-code-location *current-frame*))
863 ;; Let's only deal with valid variables.
864 (vars (remove-if-not (lambda (v)
865 (eq (sb!di:debug-var-validity v location)
866 :valid))
867 temp)))
868 (declare (list vars))
869 (cond ((null vars)
870 (error "No known valid variables match ~S." name))
871 ((= (length vars) 1)
872 ,(ecase ref-or-set
873 (:ref
874 '(sb!di:debug-var-value (car vars) *current-frame*))
875 (:set
876 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
877 ,value-var))))
879 ;; Since we have more than one, first see whether we have
880 ;; any variables that exactly match the specification.
881 (let* ((name (etypecase name
882 (symbol (symbol-name name))
883 (simple-string name)))
884 ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
885 ;; instead.
886 (exact (remove-if-not (lambda (v)
887 (string= (sb!di:debug-var-symbol-name v)
888 name))
889 vars))
890 (vars (or exact vars)))
891 (declare (simple-string name)
892 (list exact vars))
893 (cond
894 ;; Check now for only having one variable.
895 ((= (length vars) 1)
896 ,(ecase ref-or-set
897 (:ref
898 '(sb!di:debug-var-value (car vars) *current-frame*))
899 (:set
900 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
901 ,value-var))))
902 ;; If there weren't any exact matches, flame about
903 ;; ambiguity unless all the variables have the same
904 ;; name.
905 ((and (not exact)
906 (find-if-not
907 (lambda (v)
908 (string= (sb!di:debug-var-symbol-name v)
909 (sb!di:debug-var-symbol-name (car vars))))
910 (cdr vars)))
911 (error "specification ambiguous:~%~{ ~A~%~}"
912 (mapcar #'sb!di:debug-var-symbol-name
913 (delete-duplicates
914 vars :test #'string=
915 :key #'sb!di:debug-var-symbol-name))))
916 ;; All names are the same, so see whether the user
917 ;; ID'ed one of them.
918 (id-supplied
919 (let ((v (find id vars :key #'sb!di:debug-var-id)))
920 (unless v
921 (error
922 "invalid variable ID, ~W: should have been one of ~S"
924 (mapcar #'sb!di:debug-var-id vars)))
925 ,(ecase ref-or-set
926 (:ref
927 '(sb!di:debug-var-value v *current-frame*))
928 (:set
929 `(setf (sb!di:debug-var-value v *current-frame*)
930 ,value-var)))))
932 (error "Specify variable ID to disambiguate ~S. Use one of ~S."
933 name
934 (mapcar #'sb!di:debug-var-id vars)))))))))
936 ) ; EVAL-WHEN
938 ;;; FIXME: This doesn't work. It would be real nice we could make it
939 ;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
940 (defun var (name &optional (id 0 id-supplied))
941 #!+sb-doc
942 "Return a variable's value if possible. NAME is a simple-string or symbol.
943 If it is a simple-string, it is an initial substring of the variable's name.
944 If name is a symbol, it has the same name and package as the variable whose
945 value this function returns. If the symbol is uninterned, then the variable
946 has the same name as the symbol, but it has no package.
948 If name is the initial substring of variables with different names, then
949 this return no values after displaying the ambiguous names. If name
950 determines multiple variables with the same name, then you must use the
951 optional id argument to specify which one you want. If you left id
952 unspecified, then this returns no values after displaying the distinguishing
953 id values.
955 The result of this function is limited to the availability of variable
956 information. This is SETF'able."
957 (define-var-operation :ref))
958 (defun (setf var) (value name &optional (id 0 id-supplied))
959 (define-var-operation :set value))
961 ;;; This returns the COUNT'th arg as the user sees it from args, the
962 ;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
963 ;;; potential DEBUG-VAR from the lambda-list, then the second value is
964 ;;; T. If this returns a keyword symbol or a value from a rest arg,
965 ;;; then the second value is NIL.
967 ;;; FIXME: There's probably some way to merge the code here with
968 ;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
969 ;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)
970 (declaim (ftype (function (index list)) nth-arg))
971 (defun nth-arg (count args)
972 (let ((n count))
973 (dolist (ele args (error "The argument specification ~S is out of range."
975 (lambda-list-element-dispatch ele
976 :required ((if (zerop n) (return (values ele t))))
977 :optional ((if (zerop n) (return (values (second ele) t))))
978 :keyword ((cond ((zerop n)
979 (return (values (second ele) nil)))
980 ((zerop (decf n))
981 (return (values (third ele) t)))))
982 :deleted ((if (zerop n) (return (values ele t))))
983 :rest ((let ((var (second ele)))
984 (lambda-var-dispatch var (sb!di:frame-code-location
985 *current-frame*)
986 (error "unused &REST argument before n'th argument")
987 (dolist (value
988 (sb!di:debug-var-value var *current-frame*)
989 (error
990 "The argument specification ~S is out of range."
992 (if (zerop n)
993 (return-from nth-arg (values value nil))
994 (decf n)))
995 (error "invalid &REST argument before n'th argument")))))
996 (decf n))))
998 (defun arg (n)
999 #!+sb-doc
1000 "Return the N'th argument's value if possible. Argument zero is the first
1001 argument in a frame's default printed representation. Count keyword/value
1002 pairs as separate arguments."
1003 (multiple-value-bind (var lambda-var-p)
1004 (nth-arg n (handler-case (sb!di:debug-fun-lambda-list
1005 (sb!di:frame-debug-fun *current-frame*))
1006 (sb!di:lambda-list-unavailable ()
1007 (error "No argument values are available."))))
1008 (if lambda-var-p
1009 (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
1010 (error "Unused arguments have no values.")
1011 (sb!di:debug-var-value var *current-frame*)
1012 (error "invalid argument value"))
1013 var)))
1015 ;;;; machinery for definition of debug loop commands
1017 (defvar *debug-commands* nil)
1019 ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
1020 ;;; permitted.
1021 (defmacro !def-debug-command (name args &rest body)
1022 (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
1023 `(progn
1024 (setf *debug-commands*
1025 (remove ,name *debug-commands* :key #'car :test #'string=))
1026 (defun ,fun-name ,args
1027 (unless *in-the-debugger*
1028 (error "invoking debugger command while outside the debugger"))
1029 ,@body)
1030 (push (cons ,name #',fun-name) *debug-commands*)
1031 ',fun-name)))
1033 (defun !def-debug-command-alias (new-name existing-name)
1034 (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
1035 (unless pair (error "unknown debug command name: ~S" existing-name))
1036 (push (cons new-name (cdr pair)) *debug-commands*))
1037 new-name)
1039 ;;; This takes a symbol and uses its name to find a debugger command,
1040 ;;; using initial substring matching. It returns the command function
1041 ;;; if form identifies only one command, but if form is ambiguous,
1042 ;;; this returns a list of the command names. If there are no matches,
1043 ;;; this returns nil. Whenever the loop that looks for a set of
1044 ;;; possibilities encounters an exact name match, we return that
1045 ;;; command function immediately.
1046 (defun debug-command-p (form &optional other-commands)
1047 (if (or (symbolp form) (integerp form))
1048 (let* ((name
1049 (if (symbolp form)
1050 (symbol-name form)
1051 (format nil "~W" form)))
1052 (len (length name))
1053 (res nil))
1054 (declare (simple-string name)
1055 (fixnum len)
1056 (list res))
1058 ;; Find matching commands, punting if exact match.
1059 (flet ((match-command (ele)
1060 (let* ((str (car ele))
1061 (str-len (length str)))
1062 (declare (simple-string str)
1063 (fixnum str-len))
1064 (cond ((< str-len len))
1065 ((= str-len len)
1066 (when (string= name str :end1 len :end2 len)
1067 (return-from debug-command-p (cdr ele))))
1068 ((string= name str :end1 len :end2 len)
1069 (push ele res))))))
1070 (mapc #'match-command *debug-commands*)
1071 (mapc #'match-command other-commands))
1073 ;; Return the right value.
1074 (cond ((not res) nil)
1075 ((= (length res) 1)
1076 (cdar res))
1077 (t ; Just return the names.
1078 (do ((cmds res (cdr cmds)))
1079 ((not cmds) res)
1080 (setf (car cmds) (caar cmds))))))))
1082 ;;; Return a list of debug commands (in the same format as
1083 ;;; *DEBUG-COMMANDS*) that invoke each active restart.
1085 ;;; Two commands are made for each restart: one for the number, and
1086 ;;; one for the restart name (unless it's been shadowed by an earlier
1087 ;;; restart of the same name, or it is NIL).
1088 (defun make-restart-commands (&optional (restarts *debug-restarts*))
1089 (let ((commands)
1090 (num 0)) ; better be the same as show-restarts!
1091 (dolist (restart restarts)
1092 (let ((name (string (restart-name restart))))
1093 (let ((restart-fun
1094 (lambda ()
1095 (/show0 "in restart-command closure, about to i-r-i")
1096 (invoke-restart-interactively restart))))
1097 (push (cons (prin1-to-string num) restart-fun) commands)
1098 (unless (or (null (restart-name restart))
1099 (find name commands :key #'car :test #'string=))
1100 (push (cons name restart-fun) commands))))
1101 (incf num))
1102 commands))
1104 ;;;; frame-changing commands
1106 (!def-debug-command "UP" ()
1107 (let ((next (sb!di:frame-up *current-frame*)))
1108 (cond (next
1109 (setf *current-frame* next)
1110 (print-frame-call next *debug-io*))
1112 (format *debug-io* "~&Top of stack.")))))
1114 (!def-debug-command "DOWN" ()
1115 (let ((next (sb!di:frame-down *current-frame*)))
1116 (cond (next
1117 (setf *current-frame* next)
1118 (print-frame-call next *debug-io*))
1120 (format *debug-io* "~&Bottom of stack.")))))
1122 (!def-debug-command-alias "D" "DOWN")
1124 (!def-debug-command "BOTTOM" ()
1125 (do ((prev *current-frame* lead)
1126 (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
1127 ((null lead)
1128 (setf *current-frame* prev)
1129 (print-frame-call prev *debug-io*))))
1131 (!def-debug-command-alias "B" "BOTTOM")
1133 (!def-debug-command "FRAME" (&optional
1134 (n (read-prompting-maybe "frame number: ")))
1135 (setf *current-frame*
1136 (multiple-value-bind (next-frame-fun limit-string)
1137 (if (< n (sb!di:frame-number *current-frame*))
1138 (values #'sb!di:frame-up "top")
1139 (values #'sb!di:frame-down "bottom"))
1140 (do ((frame *current-frame*))
1141 ((= n (sb!di:frame-number frame))
1142 frame)
1143 (let ((next-frame (funcall next-frame-fun frame)))
1144 (cond (next-frame
1145 (setf frame next-frame))
1147 (format *debug-io*
1148 "The ~A of the stack was encountered.~%"
1149 limit-string)
1150 (return frame)))))))
1151 (print-frame-call *current-frame* *debug-io*))
1153 (!def-debug-command-alias "F" "FRAME")
1155 ;;;; commands for entering and leaving the debugger
1157 (!def-debug-command "TOPLEVEL" ()
1158 (throw 'toplevel-catcher nil))
1160 ;;; make T safe
1161 (!def-debug-command-alias "TOP" "TOPLEVEL")
1163 (!def-debug-command "RESTART" ()
1164 (/show0 "doing RESTART debug-command")
1165 (let ((num (read-if-available :prompt)))
1166 (when (eq num :prompt)
1167 (show-restarts *debug-restarts* *debug-io*)
1168 (write-string "restart: " *debug-io*)
1169 (force-output *debug-io*)
1170 (setf num (read *debug-io*)))
1171 (let ((restart (typecase num
1172 (unsigned-byte
1173 (nth num *debug-restarts*))
1174 (symbol
1175 (find num *debug-restarts* :key #'restart-name
1176 :test (lambda (sym1 sym2)
1177 (string= (symbol-name sym1)
1178 (symbol-name sym2)))))
1180 (format *debug-io* "~S is invalid as a restart name.~%"
1181 num)
1182 (return-from restart-debug-command nil)))))
1183 (/show0 "got RESTART")
1184 (if restart
1185 (invoke-restart-interactively restart)
1186 (princ "There is no such restart." *debug-io*)))))
1188 ;;;; information commands
1190 (!def-debug-command "HELP" ()
1191 ;; CMU CL had a little toy pager here, but "if you aren't running
1192 ;; ILISP (or a smart windowing system, or something) you deserve to
1193 ;; lose", so we've dropped it in SBCL. However, in case some
1194 ;; desperate holdout is running this on a dumb terminal somewhere,
1195 ;; we tell him where to find the message stored as a string.
1196 (format *debug-io*
1197 "~&~A~2%(The HELP string is stored in ~S.)~%"
1198 *debug-help-string*
1199 '*debug-help-string*))
1201 (!def-debug-command-alias "?" "HELP")
1203 (!def-debug-command "ERROR" ()
1204 (format *debug-io* "~A~%" *debug-condition*)
1205 (show-restarts *debug-restarts* *debug-io*))
1207 (!def-debug-command "BACKTRACE" ()
1208 (backtrace (read-if-available most-positive-fixnum)))
1210 (!def-debug-command "PRINT" ()
1211 (print-frame-call *current-frame* *debug-io*))
1213 (!def-debug-command-alias "P" "PRINT")
1215 (!def-debug-command "LIST-LOCALS" ()
1216 (let ((d-fun (sb!di:frame-debug-fun *current-frame*)))
1217 (if (sb!di:debug-var-info-available d-fun)
1218 (let ((*standard-output* *debug-io*)
1219 (location (sb!di:frame-code-location *current-frame*))
1220 (prefix (read-if-available nil))
1221 (any-p nil)
1222 (any-valid-p nil))
1223 (dolist (v (sb!di:ambiguous-debug-vars
1224 d-fun
1225 (if prefix (string prefix) "")))
1226 (setf any-p t)
1227 (when (eq (sb!di:debug-var-validity v location) :valid)
1228 (setf any-valid-p t)
1229 (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
1230 (sb!di:debug-var-symbol v)
1231 (zerop (sb!di:debug-var-id v))
1232 (sb!di:debug-var-id v)
1233 (sb!di:debug-var-value v *current-frame*))))
1235 (cond
1236 ((not any-p)
1237 (format *debug-io*
1238 "There are no local variables ~@[starting with ~A ~]~
1239 in the function."
1240 prefix))
1241 ((not any-valid-p)
1242 (format *debug-io*
1243 "All variables ~@[starting with ~A ~]currently ~
1244 have invalid values."
1245 prefix))))
1246 (write-line "There is no variable information available."
1247 *debug-io*))))
1249 (!def-debug-command-alias "L" "LIST-LOCALS")
1251 (!def-debug-command "SOURCE" ()
1252 (print (code-location-source-form (sb!di:frame-code-location *current-frame*)
1253 (read-if-available 0))
1254 *debug-io*))
1256 ;;;; source location printing
1258 ;;; We cache a stream to the last valid file debug source so that we
1259 ;;; won't have to repeatedly open the file.
1261 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
1262 ;;; in the 1990s, so the benefit is negligible, less important than the
1263 ;;; potential of extra confusion if someone changes the source during
1264 ;;; a debug session and the change doesn't show up. And removing this
1265 ;;; would simplify the system, which I like. -- WHN 19990903
1266 (defvar *cached-debug-source* nil)
1267 (declaim (type (or sb!di:debug-source null) *cached-debug-source*))
1268 (defvar *cached-source-stream* nil)
1269 (declaim (type (or stream null) *cached-source-stream*))
1271 ;;; To suppress the read-time evaluation #. macro during source read,
1272 ;;; *READTABLE* is modified. *READTABLE* is cached to avoid
1273 ;;; copying it each time, and invalidated when the
1274 ;;; *CACHED-DEBUG-SOURCE* has changed.
1275 (defvar *cached-readtable* nil)
1276 (declaim (type (or readtable null) *cached-readtable*))
1278 ;;; Stuff to clean up before saving a core
1279 (defun debug-deinit ()
1280 (setf *cached-debug-source* nil
1281 *cached-source-stream* nil
1282 *cached-readtable* nil))
1284 ;;; We also cache the last toplevel form that we printed a source for
1285 ;;; so that we don't have to do repeated reads and calls to
1286 ;;; FORM-NUMBER-TRANSLATIONS.
1287 (defvar *cached-toplevel-form-offset* nil)
1288 (declaim (type (or index null) *cached-toplevel-form-offset*))
1289 (defvar *cached-toplevel-form*)
1290 (defvar *cached-form-number-translations*)
1292 ;;; Given a code location, return the associated form-number
1293 ;;; translations and the actual top level form. We check our cache ---
1294 ;;; if there is a miss, we dispatch on the kind of the debug source.
1295 (defun get-toplevel-form (location)
1296 (let ((d-source (sb!di:code-location-debug-source location)))
1297 (if (and (eq d-source *cached-debug-source*)
1298 (eql (sb!di:code-location-toplevel-form-offset location)
1299 *cached-toplevel-form-offset*))
1300 (values *cached-form-number-translations* *cached-toplevel-form*)
1301 (let* ((offset (sb!di:code-location-toplevel-form-offset location))
1302 (res
1303 (ecase (sb!di:debug-source-from d-source)
1304 (:file (get-file-toplevel-form location))
1305 (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
1306 (setq *cached-toplevel-form-offset* offset)
1307 (values (setq *cached-form-number-translations*
1308 (sb!di:form-number-translations res offset))
1309 (setq *cached-toplevel-form* res))))))
1311 ;;; Locate the source file (if it still exists) and grab the top level
1312 ;;; form. If the file is modified, we use the top level form offset
1313 ;;; instead of the recorded character offset.
1314 (defun get-file-toplevel-form (location)
1315 (let* ((d-source (sb!di:code-location-debug-source location))
1316 (tlf-offset (sb!di:code-location-toplevel-form-offset location))
1317 (local-tlf-offset (- tlf-offset
1318 (sb!di:debug-source-root-number d-source)))
1319 (char-offset
1320 (aref (or (sb!di:debug-source-start-positions d-source)
1321 (error "no start positions map"))
1322 local-tlf-offset))
1323 (name (sb!di:debug-source-name d-source)))
1324 (unless (eq d-source *cached-debug-source*)
1325 (unless (and *cached-source-stream*
1326 (equal (pathname *cached-source-stream*)
1327 (pathname name)))
1328 (setq *cached-readtable* nil)
1329 (when *cached-source-stream* (close *cached-source-stream*))
1330 (setq *cached-source-stream* (open name :if-does-not-exist nil))
1331 (unless *cached-source-stream*
1332 (error "The source file no longer exists:~% ~A" (namestring name)))
1333 (format *debug-io* "~%; file: ~A~%" (namestring name)))
1335 (setq *cached-debug-source*
1336 (if (= (sb!di:debug-source-created d-source)
1337 (file-write-date name))
1338 d-source nil)))
1340 (cond
1341 ((eq *cached-debug-source* d-source)
1342 (file-position *cached-source-stream* char-offset))
1344 (format *debug-io*
1345 "~%; File has been modified since compilation:~%; ~A~@
1346 ; Using form offset instead of character position.~%"
1347 (namestring name))
1348 (file-position *cached-source-stream* 0)
1349 (let ((*read-suppress* t))
1350 (dotimes (i local-tlf-offset)
1351 (read *cached-source-stream*)))))
1352 (unless *cached-readtable*
1353 (setq *cached-readtable* (copy-readtable))
1354 (set-dispatch-macro-character
1355 #\# #\.
1356 (lambda (stream sub-char &rest rest)
1357 (declare (ignore rest sub-char))
1358 (let ((token (read stream t nil t)))
1359 (format nil "#.~S" token)))
1360 *cached-readtable*))
1361 (let ((*readtable* *cached-readtable*))
1362 (read *cached-source-stream*))))
1364 (defun code-location-source-form (location context)
1365 (let* ((location (maybe-block-start-location location))
1366 (form-num (sb!di:code-location-form-number location)))
1367 (multiple-value-bind (translations form) (get-toplevel-form location)
1368 (unless (< form-num (length translations))
1369 (error "The source path no longer exists."))
1370 (sb!di:source-path-context form
1371 (svref translations form-num)
1372 context))))
1375 ;;; start single-stepping
1376 (!def-debug-command "START" ()
1377 (if (typep *debug-condition* 'step-condition)
1378 (format *debug-io* "~&Already single-stepping.~%")
1379 (let ((restart (find-restart 'continue *debug-condition*)))
1380 (cond (restart
1381 (sb!impl::enable-stepping)
1382 (invoke-restart restart))
1384 (format *debug-io* "~&Non-continuable error, cannot start stepping.~%"))))))
1386 (defmacro def-step-command (command-name restart-name)
1387 `(!def-debug-command ,command-name ()
1388 (if (typep *debug-condition* 'step-condition)
1389 (let ((restart (find-restart ',restart-name *debug-condition*)))
1390 (aver restart)
1391 (invoke-restart restart))
1392 (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))))
1394 (def-step-command "STEP" step-into)
1395 (def-step-command "NEXT" step-next)
1396 (def-step-command "STOP" step-continue)
1398 (!def-debug-command-alias "S" "STEP")
1399 (!def-debug-command-alias "N" "NEXT")
1401 (!def-debug-command "OUT" ()
1402 (if (typep *debug-condition* 'step-condition)
1403 (if sb!impl::*step-out*
1404 (let ((restart (find-restart 'step-out *debug-condition*)))
1405 (aver restart)
1406 (invoke-restart restart))
1407 (format *debug-io* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%"))
1408 (format *debug-io* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))
1410 ;;; miscellaneous commands
1412 (!def-debug-command "DESCRIBE" ()
1413 (let* ((curloc (sb!di:frame-code-location *current-frame*))
1414 (debug-fun (sb!di:code-location-debug-fun curloc))
1415 (function (sb!di:debug-fun-fun debug-fun)))
1416 (if function
1417 (describe function)
1418 (format *debug-io* "can't figure out the function for this frame"))))
1420 (!def-debug-command "SLURP" ()
1421 (loop while (read-char-no-hang *standard-input*)))
1423 ;;; RETURN-FROM-FRAME and RESTART-FRAME
1425 (defun unwind-to-frame-and-call (frame thunk)
1426 #!+unwind-to-frame-and-call-vop
1427 (flet ((sap-int/fixnum (sap)
1428 ;; On unithreaded X86 *BINDING-STACK-POINTER* and
1429 ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through
1430 ;; some hoops to make these calculated values negative too.
1431 (ash (truly-the (signed-byte #.sb!vm:n-word-bits)
1432 (sap-int sap))
1433 (- sb!vm::n-fixnum-tag-bits))))
1434 ;; To properly unwind the stack, we need three pieces of information:
1435 ;; * The unwind block that should be active after the unwind
1436 ;; * The catch block that should be active after the unwind
1437 ;; * The values that the binding stack pointer should have after the
1438 ;; unwind.
1439 (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame)))
1440 (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame))))
1441 ;; This VOP will run the neccessary cleanup forms, reset the fp, and
1442 ;; then call the supplied function.
1443 (sb!vm::%primitive sb!vm::unwind-to-frame-and-call
1444 (sb!di::frame-pointer frame)
1445 (find-enclosing-uwp frame)
1446 (lambda ()
1447 ;; Before calling the user-specified
1448 ;; function, we need to restore the binding
1449 ;; stack and the catch block. The unwind block
1450 ;; is taken care of by the VOP.
1451 (sb!vm::%primitive sb!vm::unbind-to-here
1452 unbind-to)
1453 (setf sb!vm::*current-catch-block* block)
1454 (funcall thunk)))))
1455 #!-unwind-to-frame-and-call-vop
1456 (let ((tag (gensym)))
1457 (sb!di:replace-frame-catch-tag frame
1458 'sb!c:debug-catch-tag
1459 tag)
1460 (throw tag thunk)))
1462 (defun find-binding-stack-pointer (frame)
1463 #!-stack-grows-downward-not-upward
1464 (declare (ignore frame))
1465 #!-stack-grows-downward-not-upward
1466 (error "Not implemented on this architecture")
1467 #!+stack-grows-downward-not-upward
1468 (let ((bsp (sb!vm::binding-stack-pointer-sap))
1469 (unbind-to nil)
1470 (fp (sb!di::frame-pointer frame))
1471 (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1472 (ash sb!vm:*binding-stack-start*
1473 sb!vm:n-fixnum-tag-bits)))))
1474 ;; Walk the binding stack looking for an entry where the symbol is
1475 ;; an unbound-symbol marker and the value is equal to the frame
1476 ;; pointer. These entries are inserted into the stack by the
1477 ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into
1478 ;; the function during IR2). If an entry wasn't found, the
1479 ;; function that the frame corresponds to wasn't compiled with a
1480 ;; high enough debug setting, and can't be restarted / returned
1481 ;; from.
1482 (loop until (sap= bsp start)
1483 do (progn
1484 (setf bsp (sap+ bsp
1485 (- (* sb!vm:binding-size sb!vm:n-word-bytes))))
1486 (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot
1487 sb!vm:n-word-bytes)))
1488 (value (sap-ref-sap bsp (* sb!vm:binding-value-slot
1489 sb!vm:n-word-bytes))))
1490 (when (eql symbol sb!vm:unbound-marker-widetag)
1491 (when (sap= value fp)
1492 (setf unbind-to bsp))))))
1493 unbind-to))
1495 (defun find-enclosing-catch-block (frame)
1496 ;; Walk the catch block chain looking for the first entry with an address
1497 ;; higher than the pointer for FRAME or a null pointer.
1498 (let* ((frame-pointer (sb!di::frame-pointer frame))
1499 (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1500 (ash sb!vm::*current-catch-block*
1501 sb!vm:n-fixnum-tag-bits))))
1502 (enclosing-block (loop for block = current-block
1503 then (sap-ref-sap block
1504 (* sb!vm:catch-block-previous-catch-slot
1505 sb!vm::n-word-bytes))
1506 when (or (zerop (sap-int block))
1507 (sap> block frame-pointer))
1508 return block)))
1509 enclosing-block))
1511 (defun find-enclosing-uwp (frame)
1512 ;; Walk the UWP chain looking for the first entry with an address
1513 ;; higher than the pointer for FRAME or a null pointer.
1514 (let* ((frame-pointer (sb!di::frame-pointer frame))
1515 (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
1516 (ash sb!vm::*current-unwind-protect-block*
1517 sb!vm:n-fixnum-tag-bits))))
1518 (enclosing-uwp (loop for uwp-block = current-uwp
1519 then (sap-ref-sap uwp-block
1520 sb!vm:unwind-block-current-uwp-slot)
1521 when (or (zerop (sap-int uwp-block))
1522 (sap> uwp-block frame-pointer))
1523 return uwp-block)))
1524 enclosing-uwp))
1526 (!def-debug-command "RETURN" (&optional
1527 (return (read-prompting-maybe
1528 "return: ")))
1529 (if (frame-has-debug-tag-p *current-frame*)
1530 (let* ((code-location (sb!di:frame-code-location *current-frame*))
1531 (values (multiple-value-list
1532 (funcall (sb!di:preprocess-for-eval return code-location)
1533 *current-frame*))))
1534 (unwind-to-frame-and-call *current-frame* (lambda ()
1535 (values-list values))))
1536 (format *debug-io*
1537 "~@<can't find a tag for this frame ~
1538 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1539 and recompiling)~:@>")))
1541 (!def-debug-command "RESTART-FRAME" ()
1542 (if (frame-has-debug-tag-p *current-frame*)
1543 (let* ((call-list (frame-call-as-list *current-frame*))
1544 (fun (fdefinition (car call-list))))
1545 (unwind-to-frame-and-call *current-frame*
1546 (lambda ()
1547 (apply fun (cdr call-list)))))
1548 (format *debug-io*
1549 "~@<can't find a tag for this frame ~
1550 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1551 and recompiling)~:@>")))
1553 (defun frame-has-debug-tag-p (frame)
1554 #!+unwind-to-frame-and-call-vop
1555 (not (null (find-binding-stack-pointer frame)))
1556 #!-unwind-to-frame-and-call-vop
1557 (find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car))
1559 ;; Hack: ensure that *U-T-F-F* has a tls index.
1560 #!+unwind-to-frame-and-call-vop
1561 (let ((sb!vm::*unwind-to-frame-function* (lambda ()))))
1564 ;;;; debug loop command utilities
1566 (defun read-prompting-maybe (prompt)
1567 (unless (sb!int:listen-skip-whitespace *debug-io*)
1568 (princ prompt *debug-io*)
1569 (force-output *debug-io*))
1570 (read *debug-io*))
1572 (defun read-if-available (default)
1573 (if (sb!int:listen-skip-whitespace *debug-io*)
1574 (read *debug-io*)
1575 default))