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