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