3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!DEBUG")
14 ;;;; variables and constants
16 ;;; things to consider when tweaking these values:
17 ;;; * We're afraid to just default them to NIL and NIL, in case the
18 ;;; user inadvertently causes a hairy data structure to be printed
19 ;;; when he inadvertently enters the debugger.
20 ;;; * We don't want to truncate output too much. These days anyone
21 ;;; can easily run their Lisp in a windowing system or under Emacs,
22 ;;; so it's not the end of the world even if the worst case is a
23 ;;; few thousand lines of output.
24 ;;; * As condition :REPORT methods are converted to use the pretty
25 ;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
26 ;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
27 ;;; ARG-COUNT-ERROR printed as
28 ;;; error while parsing arguments to DESTRUCTURING-BIND:
29 ;;; invalid number of elements in
31 ;;; to satisfy lambda list
33 ;;; exactly 2 expected, but 5 found
34 (defvar *debug-print-variable-alist
* nil
35 "an association list describing new bindings for special variables
36 to be used within the debugger. Eg.
38 ((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))
40 The variables in the CAR positions are bound to the values in the CDR
41 during the execution of some debug commands. When evaluating arbitrary
42 expressions in the debugger, the normal values of the printer control
43 variables are in effect.
45 Initially empty, *DEBUG-PRINT-VARIABLE-ALIST* is typically used to
46 provide bindings for printer control variables.")
48 (defvar *debug-readtable
*
49 ;; KLUDGE: This can't be initialized in a cold toplevel form,
50 ;; because the *STANDARD-READTABLE* isn't initialized until after
51 ;; cold toplevel forms have run. So instead we initialize it
52 ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
54 "*READTABLE* for the debugger")
56 (defvar *in-the-debugger
* nil
57 "This is T while in the debugger.")
59 ;;; nestedness inside debugger command loops
60 (defvar *debug-command-level
* 0)
62 ;;; If this is bound before the debugger is invoked, it is used as the stack
63 ;;; top by the debugger. It can either be the first interesting frame, or the
64 ;;; name of the last uninteresting frame.
65 ;;; This is a !DEFVAR so that cold-init can use SIGNAL.
66 ;;; It actually works as long as the condition is not a subtype of WARNING
67 ;;; or ERROR. (Any other direct descendant of CONDITION should be fine)
68 (!defvar
*stack-top-hint
* nil
)
70 (defvar *real-stack-top
* nil
)
71 (defvar *stack-top
* nil
)
73 (defvar *current-frame
* nil
)
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?")
82 (defun debug-prompt (stream)
83 (sb!thread
::get-foreground
)
86 (sb!di
:frame-number
*current-frame
*)
87 (> *debug-command-level
* 1)
88 *debug-command-level
*))
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
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.
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
114 UP up frame DOWN down frame
115 BOTTOM bottom frame FRAME n frame n (n=0 for top frame)
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.
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.
133 Function and macro commands:
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.
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.
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.
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.)")
155 (defmacro with-debug-io-syntax
(() &body body
)
156 (let ((thunk (sb!xc
:gensym
"THUNK")))
157 `(dx-flet ((,thunk
()
159 (funcall-with-debug-io-syntax #',thunk
))))
161 ;;; If LOC is an unknown location, then try to find the block start
162 ;;; location. Used by source printing to some information instead of
163 ;;; none for the user.
164 (defun maybe-block-start-location (loc)
165 (if (sb!di
:code-location-unknown-p loc
)
166 (let* ((block (sb!di
:code-location-debug-block loc
))
167 (start (sb!di
:do-debug-block-locations
(loc block
)
169 (cond ((and (not (sb!di
:debug-block-elsewhere-p block
))
171 (format *debug-io
* "~%unknown location: using block start~%")
179 (declaim (unsigned-byte *backtrace-frame-count
*))
180 (defvar *backtrace-frame-count
* 1000
181 "Default number of frames to backtrace. Defaults to 1000.")
183 (declaim (type (member :minimal
:normal
:full
) *method-frame-style
*))
184 (defvar *method-frame-style
* :normal
185 "Determines how frames corresponding to method functions are represented in
186 backtraces. Possible values are :MINIMAL, :NORMAL, and :FULL.
188 :MINIMAL represents them as
190 (<gf-name> ...args...)
192 if all arguments are available, and only a single method is applicable to
193 the arguments -- otherwise behaves as :NORMAL.
195 :NORMAL represents them as
197 ((:method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
199 The frame is then followed by either [fast-method] or [slow-method],
200 designating the kind of method function. (See below.)
202 :FULL represents them using the actual funcallable method function name:
204 ((sb-pcl:fast-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
208 ((sb-pcl:slow-method <gf-name> [<qualifier>*] (<specializer>*)) ...args...)
210 In the this case arguments may include values internal to SBCL's method
211 dispatch machinery.")
213 (define-deprecated-variable :early
"1.1.4.9" *show-entry-point-details
*
216 (define-deprecated-function :early
"1.2.15" backtrace
(print-backtrace)
217 (&optional
(count *backtrace-frame-count
*) (stream *debug-io
*))
218 (print-backtrace :count count
:stream stream
))
220 (define-deprecated-function :early
"1.2.15" backtrace-as-list
(list-backtrace)
221 (&optional
(count *backtrace-frame-count
*))
222 (list-backtrace :count count
))
224 (defun backtrace-start-frame (frame-designator)
225 (let ((here (sb!di
:top-frame
)))
226 (labels ((current-frame ()
228 ;; Our caller's caller.
230 do
(setf frame
(or (sb!di
:frame-down frame
) frame
)))
232 (interrupted-frame ()
233 (or (find-interrupted-frame)
235 (cond ((eq :current-frame frame-designator
)
237 ((eq :interrupted-frame frame-designator
)
239 ((eq :debugger-frame frame-designator
)
240 (if (and *in-the-debugger
* *current-frame
*)
242 (interrupted-frame)))
243 ((sb!di
:frame-p frame-designator
)
246 (error "Invalid designator for initial backtrace frame: ~S"
247 frame-designator
))))))
249 (defun map-backtrace (function &key
251 (from :debugger-frame
)
252 (count *backtrace-frame-count
*))
253 "Calls the designated FUNCTION with each frame on the call stack.
254 Returns the last value returned by FUNCTION.
256 COUNT is the number of frames to backtrace, defaulting to
257 *BACKTRACE-FRAME-COUNT*.
259 START is the number of the frame the backtrace should start from.
261 FROM specifies the frame relative to which the frames are numbered. Possible
262 values are an explicit SB-DI:FRAME object, and the
263 keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
267 specifies the caller of MAP-BACKTRACE.
270 specifies the first interrupted frame on the stack \(typically the frame
271 where the error occurred, as opposed to error handling frames) if any,
272 otherwise behaving as :CURRENT-FRAME.
275 specifies the currently debugged frame when inside the debugger, and
276 behaves as :INTERRUPTED-FRAME outside the debugger.
278 (loop with result
= nil
280 for frame
= (backtrace-start-frame from
)
281 then
(sb!di
:frame-down frame
)
283 when
(<= start index
) do
284 (if (minusp (decf count
))
286 (setf result
(funcall function frame
)))
287 finally
(return result
)))
289 (defun print-backtrace (&key
292 (from :debugger-frame
)
293 (count *backtrace-frame-count
*)
295 (print-frame-source nil
)
296 (method-frame-style *method-frame-style
*)
297 (emergency-best-effort (> *debug-command-level
* 1)))
298 "Print a listing of the call stack to STREAM, defaulting to *DEBUG-IO*.
300 COUNT is the number of frames to backtrace, defaulting to
301 *BACKTRACE-FRAME-COUNT*.
303 START is the number of the frame the backtrace should start from.
305 FROM specifies the frame relative to which the frames are numbered. Possible
306 values are an explicit SB-DI:FRAME object, and the
307 keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
311 specifies the caller of PRINT-BACKTRACE.
314 specifies the first interrupted frame on the stack \(typically the frame
315 where the error occured, as opposed to error handling frames) if any,
316 otherwise behaving as :CURRENT-FRAME.
319 specifies the currently debugged frame when inside the debugger, and
320 behaves as :INTERRUPTED-FRAME outside the debugger.
322 If PRINT-THREAD is true (default), backtrace is preceded by printing the
323 thread object the backtrace is from.
325 If PRINT-FRAME-SOURCE is true (default is false), each frame is followed by
326 printing the currently executing source form in the function responsible for
327 that frame, when available. Requires the function to have been compiled at
328 DEBUG 2 or higher. If PRINT-FRAME-SOURCE is :ALWAYS, it also reports \"no
329 source available\" for frames for which were compiled at lower debug settings.
331 METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
332 corresponding to method functions are printed. Possible values
333 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
336 If EMERGENCY-BEST-EFFORT is true then try to print as much information as
337 possible while navigating and ignoring possible errors."
338 (let ((start-frame (backtrace-start-frame from
)))
339 (with-debug-io-syntax ()
340 (let ((*suppress-print-errors
* (if (and emergency-best-effort
341 (not (subtypep 'serious-condition
*suppress-print-errors
*)))
343 *suppress-print-errors
*))
346 ((print-frame (frame stream
)
347 (print-frame-call frame stream
349 :method-frame-style method-frame-style
350 :print-frame-source print-frame-source
351 :emergency-best-effort emergency-best-effort
))
352 (print-frame/normal
(frame)
353 (print-frame frame stream
))
354 (print-frame/emergency-best-effort
(frame)
355 (with-open-stream (buffer (make-string-output-stream))
359 (print-frame frame buffer
)
360 (write-string (get-output-stream-string buffer
) stream
))
361 (serious-condition (error)
362 (print-unreadable-object (error stream
:type t
)
363 (format stream
"while printing frame ~S. The partial output is: ~S"
364 frame-index
(get-output-stream-string buffer
))))))))
366 ((print-not-readable #'print-unreadably
))
369 (format stream
"Backtrace for: ~S~%" sb
!thread
:*current-thread
*))
370 (map-backtrace (lambda (frame)
372 (if emergency-best-effort
373 (print-frame/emergency-best-effort frame
)
374 (print-frame/normal frame
))
375 (skip-printing-frame ()
376 :report
(lambda (stream)
377 (format stream
"Skip printing frame ~S" frame-index
))
378 (print-unreadable-object (frame stream
:type t
:identity t
))))
386 (defun list-backtrace (&key
387 (count *backtrace-frame-count
*)
389 (from :debugger-frame
)
390 (method-frame-style *method-frame-style
*))
391 "Returns a list describing the call stack. Each frame is represented
396 where the name describes the function responsible for the frame. The name
397 might not be bound to the actual function object. Unavailable arguments are
398 represented by dummy objects that print as #<unavailable argument>. Objects
399 with dynamic-extent allocation by the current thread are represented by
400 substitutes to avoid references to them from leaking outside their legal
403 COUNT is the number of frames to backtrace, defaulting to
404 *BACKTRACE-FRAME-COUNT*.
406 START is the number of the frame the backtrace should start from.
408 FROM specifies the frame relative to which the frames are numbered. Possible
409 values are an explicit SB-DI:FRAME object, and the
410 keywords :CURRENT-FRAME, :INTERRUPTED-FRAME, and :DEBUGGER-FRAME. Default
414 specifies the caller of LIST-BACKTRACE.
417 specifies the first interrupted frame on the stack \(typically the frame
418 where the error occured, as opposed to error handling frames) if any,
419 otherwise behaving as :CURRENT-FRAME.
422 specifies the currently debugged frame when inside the debugger, and
423 behaves as :INTERRUPTED-FRAME outside the debugger.
425 METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
426 corresponding to method functions are printed. Possible values
427 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
432 (push (frame-call-as-list frame
:method-frame-style method-frame-style
)
436 :from
(backtrace-start-frame from
))
437 (nreverse rbacktrace
)))
439 (defun frame-call-as-list (frame &key
(method-frame-style *method-frame-style
*))
440 (multiple-value-bind (name args info
)
441 (frame-call frame
:method-frame-style method-frame-style
442 :replace-dynamic-extent-objects t
)
443 (values (cons name args
) info
)))
445 (defun replace-dynamic-extent-object (obj)
446 (if (stack-allocated-p obj
)
447 (make-unprintable-object
449 (format nil
"dynamic-extent: ~S" obj
)
451 "error printing dynamic-extent object")))
454 (defun stack-allocated-p (obj)
455 "Returns T if OBJ is allocated on the stack of the current
456 thread, NIL otherwise."
457 (with-pinned-objects (obj)
458 (let ((sap (int-sap (get-lisp-obj-address obj
))))
459 (when (sb!vm
:control-stack-pointer-valid-p sap nil
)
464 (eval-when (:compile-toplevel
:execute
)
466 ;;; This is a convenient way to express what to do for each type of
467 ;;; lambda-list element.
468 (sb!xc
:defmacro lambda-list-element-dispatch
(element
480 (ecase (car ,element
)
481 (:optional
,@optional
)
486 (aver (eq ,element
:deleted
))
489 (sb!xc
:defmacro lambda-var-dispatch
(variable location deleted valid other
)
490 (let ((var (gensym)))
491 `(let ((,var
,variable
))
492 (cond ((eq ,var
:deleted
) ,deleted
)
493 ((eq (sb!di
:debug-var-validity
,var
,location
) :valid
)
499 ;;; Extract the function argument values for a debug frame.
500 (defun map-frame-args (thunk frame
)
501 (let ((debug-fun (sb!di
:frame-debug-fun frame
)))
502 (dolist (element (sb!di
:debug-fun-lambda-list debug-fun
))
503 (funcall thunk element
))))
505 ;;; When the frame is interrupted before any of the function code is called
506 ;;; we can recover all the arguments, include the extra ones.
507 ;;; This includes the ARG-COUNT-ERROR on #+precise-arg-count-error and
508 ;;; UNDEFINED-FUNCTION coming from undefined-tramp
509 (defun early-frame-nth-arg (n frame
)
510 (let* ((escaped (sb!di
::compiled-frame-escaped frame
))
511 (pointer (sb!di
::frame-pointer frame
))
512 (arg-count (sb!di
::sub-access-debug-var-slot
513 pointer sb
!c
:arg-count-sc escaped
)))
516 (sb!di
::sub-access-debug-var-slot
518 (sb!c
:standard-arg-location-sc n
)
520 (error "Index ~a out of bounds for ~a supplied argument~:p." n arg-count
))))
522 (defun early-frame-args (frame)
523 (let* ((escaped (sb!di
::compiled-frame-escaped frame
))
524 (pointer (sb!di
::frame-pointer frame
))
525 (arg-count (sb!di
::sub-access-debug-var-slot
526 pointer sb
!c
:arg-count-sc escaped
)))
527 (loop for i below arg-count
528 collect
(sb!di
::sub-access-debug-var-slot
530 (sb!c
:standard-arg-location-sc i
)
533 (defun frame-args-as-list (frame)
534 (when (sb!di
::all-args-available-p frame
)
535 (return-from frame-args-as-list
536 (early-frame-args frame
)))
538 (let ((location (sb!di
:frame-code-location frame
))
539 (reversed-result nil
))
543 (lambda-list-element-dispatch element
544 :required
((push (frame-call-arg element location frame
) reversed-result
))
545 :optional
((push (frame-call-arg (second element
) location frame
)
547 :keyword
((push (second element
) reversed-result
)
548 (push (frame-call-arg (third element
) location frame
)
550 :deleted
((push (frame-call-arg element location frame
) reversed-result
))
551 :rest
((lambda-var-dispatch (second element
) location
553 (let ((rest (sb!di
:debug-var-value
(second element
) frame
)))
555 (setf reversed-result
(append (reverse rest
) reversed-result
))
556 (push (make-unprintable-object "unavailable &REST argument")
558 (return-from enumerating
))
559 (push (make-unprintable-object
560 "unavailable &REST argument")
562 :more
((lambda-var-dispatch (second element
) location
564 (let ((context (sb!di
:debug-var-value
(second element
) frame
))
565 (count (sb!di
:debug-var-value
(third element
) frame
)))
566 (setf reversed-result
569 (sb!c
::%more-arg-values context
0 count
)))
571 (return-from enumerating
))
572 (push (make-unprintable-object "unavailable &MORE argument")
575 (nreverse reversed-result
))
576 (sb!di
:lambda-list-unavailable
()
577 (make-unprintable-object "unavailable lambda list"))))
579 (defun clean-xep (frame name args info
)
581 #!-precise-arg-count-error
583 (let* ((count (first args
))
584 (real-args (rest args
)))
585 (if (and (integerp count
)
586 (sb!di
::all-args-available-p frame
))
587 ;; So, this is a cheap trick -- but makes backtraces for
588 ;; too-many-arguments-errors much, much easier to to
591 for arg
= (if real-args
593 (make-unprintable-object "unknown"))
598 #!+precise-arg-count-error
599 (if (and (consp args
)
600 ;; EARLY-FRAME-ARGS doesn't include arg-count
601 (not (sb!di
::all-args-available-p frame
)))
606 (defun clean-&more-processor
(name args info
)
609 (let* ((more (last args
2))
610 (context (first more
))
611 (count (second more
)))
616 (sb!c
:%more-arg-values context
0 count
))
618 (make-unprintable-object "more unavailable arguments")))))
622 (defun clean-fast-method (name args style info
)
623 (declare (type (member :minimal
:normal
:full
) style
))
624 (multiple-value-bind (cname cargs
)
625 ;; Make no attempt to simplify the display if ARGS could not be found
626 ;; due to low (OPTIMIZE (DEBUG)) quality in the method.
627 (if (or (eq style
:full
) (not (listp args
)))
629 (let ((gf-name (second name
))
630 (real-args (the list
(cddr args
)))) ; strip .PV. and .N-M-CALL.
631 (if (and (eq style
:minimal
)
633 (notany #'sb
!impl
::unprintable-object-p real-args
)
634 (singleton-p (compute-applicable-methods
635 (fdefinition gf-name
) real-args
)))
636 (values gf-name real-args
)
637 (values (cons :method
(cdr name
)) real-args
))))
638 (values cname cargs
(cons :fast-method info
))))
640 (defun clean-frame-call (frame name method-frame-style info
)
641 (let ((args (frame-args-as-list frame
)))
642 (cond ((memq :external info
)
643 (clean-xep frame name args info
))
645 (clean-&more-processor name args info
))
647 (eq (car name
) 'sb
!pcl
::fast-method
))
648 (clean-fast-method name args method-frame-style info
))
650 (values name args info
)))))
652 (defun frame-call (frame &key
(method-frame-style *method-frame-style
*)
653 replace-dynamic-extent-objects
)
654 "Returns as multiple values a descriptive name for the function responsible
655 for FRAME, arguments that that function, and a list providing additional
656 information about the frame.
658 Unavailable arguments are represented using dummy-objects printing as
659 #<unavailable argument>.
661 METHOD-FRAME-STYLE (defaulting to *METHOD-FRAME-STYLE*), determines how frames
662 corresponding to method functions are printed. Possible values
663 are :MINIMAL, :NORMAL, and :FULL. See *METHOD-FRAME-STYLE* for more
666 If REPLACE-DYNAMIC-EXTENT-OBJECTS is true, objects allocated on the stack of
667 the current thread are replaced with dummy objects which can safely escape."
668 (let* ((debug-fun (sb!di
:frame-debug-fun frame
))
669 (kind (sb!di
:debug-fun-kind debug-fun
)))
670 (multiple-value-bind (name args info
)
671 (clean-frame-call frame
672 (or (sb!di
:debug-fun-closure-name debug-fun frame
)
673 (sb!di
:debug-fun-name debug-fun
))
675 (when kind
(list kind
)))
676 (let ((args (if (and (consp args
) replace-dynamic-extent-objects
)
677 (mapcar #'replace-dynamic-extent-object args
)
679 (values name args info
)))))
681 (defun ensure-printable-object (object)
683 (with-open-stream (out (make-broadcast-stream))
687 (declare (ignore cond
))
688 (make-unprintable-object "error printing object"))))
690 (defun frame-call-arg (var location frame
)
691 (lambda-var-dispatch var location
692 (make-unprintable-object "unused argument")
693 (sb!di
:debug-var-value var frame
)
694 (make-unprintable-object "unavailable argument")))
696 ;;; Prints a representation of the function call causing FRAME to
697 ;;; exist. VERBOSITY indicates the level of information to output;
698 ;;; zero indicates just printing the DEBUG-FUN's name, and one
699 ;;; indicates displaying call-like, one-liner format with argument
701 (defun print-frame-call (frame stream
702 &key print-frame-source
704 (method-frame-style *method-frame-style
*)
705 (emergency-best-effort (> *debug-command-level
* 1)))
707 (format stream
"~&~S: " (if (integerp number
)
709 (sb!di
:frame-number frame
))))
710 (multiple-value-bind (name args info
)
711 (frame-call frame
:method-frame-style method-frame-style
)
712 (pprint-logical-block (stream nil
:prefix
"(" :suffix
")")
713 (let ((*print-pretty
* nil
)
715 ;; Since we go to some trouble to make nice informative
716 ;; function names like (PRINT-OBJECT :AROUND (CLOWN T)), let's
717 ;; make sure that they aren't truncated by *PRINT-LENGTH* and
719 (let ((*print-length
* nil
)
721 (name (if emergency-best-effort
722 (ensure-printable-object name
)
724 (write name
:stream stream
:escape t
:pretty
(equal '(lambda ()) name
)))
726 ;; For the function arguments, we can just print normally. If
727 ;; we hit a &REST arg, then print as many of the values as
728 ;; possible, punting the loop over lambda-list variables since
729 ;; any other arguments will be in the &REST arg's list of
731 (let ((args (if emergency-best-effort
732 (ensure-printable-object args
)
734 (cond ((not (listp args
))
735 (format stream
" ~S" args
))
738 (write-char #\space stream
)
739 (pprint-newline :linear stream
)
740 (cond ((and (stringp arg
) (>= (length arg
) 100))
741 (print-unreadable-object (arg stream
:type nil
:identity t
)
742 (format stream
"~A \"~A...\" (len=~D)"
744 (simple-base-string 'simple-base-string
)
745 (base-string 'base-string
)
746 (simple-string 'simple-string
)
748 (make-array 50 :element-type
(array-element-type arg
)
752 (write arg
:stream stream
:escape t
)))))))))
754 (format stream
" [~{~(~A~)~^,~}]" info
)))
755 (when print-frame-source
756 (let* ((loc (sb!di
:frame-code-location frame
))
757 (path (and (sb!di
::compiled-debug-fun-p
758 (sb!di
:code-location-debug-fun loc
))
759 (handler-case (sb!di
:code-location-debug-source loc
)
760 (sb!di
:no-debug-blocks
())
762 (sb!di
:debug-source-namestring source
))))))
763 (when (or (eq print-frame-source
:always
)
764 ;; Avoid showing sources for internals,
765 ;; it will either fail anyway due to all the SB! and
766 ;; reader conditionals or show something nobody has
768 (not (eql (search "SYS:SRC;" path
) 0)))
770 (let ((source (handler-case
771 (code-location-source-form loc
0)
773 (format stream
"~& error finding frame source: ~A" c
)))))
774 (format stream
"~% source: ~S" source
))
775 (sb!di
:debug-condition
()
776 ;; This is mostly noise.
777 (when (eq :always print-frame-source
)
778 (format stream
"~& no source available for frame")))
780 (format stream
"~& error printing frame source: ~A" c
)))))))
784 (defvar *debugger-hook
* nil
785 "This is either NIL or a function of two arguments, a condition and the value
786 of *DEBUGGER-HOOK*. This function can either handle the condition or return
787 which causes the standard debugger to execute. The system passes the value
788 of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
789 around the invocation.")
791 (defvar *invoke-debugger-hook
* nil
792 "This is either NIL or a designator for a function of two arguments,
793 to be run when the debugger is about to be entered. The function is
794 run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
795 errors, and receives as arguments the condition that triggered
796 debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
798 This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
799 In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
802 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
803 (defvar *debug-restarts
*)
804 (defvar *debug-condition
*)
805 (defvar *nested-debug-condition
*)
807 ;;; Oh, what a tangled web we weave when we preserve backwards
808 ;;; compatibility with 1968-style use of global variables to control
809 ;;; per-stream i/o properties; there's really no way to get this
810 ;;; quite right, but we do what we can.
811 (defun funcall-with-debug-io-syntax (fun &rest rest
)
812 (declare (type function fun
))
813 ;; Try to force the other special variables into a useful state.
814 (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
815 ;; any default we might use is less useful than just reusing
816 ;; the global values.
817 (original-package *package
*)
818 (original-print-pretty *print-pretty
*))
819 (with-standard-io-syntax
821 (let (;; We want the printer and reader to be in a useful
822 ;; state, regardless of where the debugger was invoked
823 ;; in the program. WITH-STANDARD-IO-SYNTAX and
824 ;; WITH-SANE-IO-SYNTAX do much of what we want, but
825 ;; * It doesn't affect our internal special variables
826 ;; like *CURRENT-LEVEL-IN-PRINT*.
827 ;; * It isn't customizable.
828 ;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not
829 ;; helpful behavior for a debugger.
830 ;; * There's no particularly good debugger default for
831 ;; *PRINT-PRETTY*, since T is usually what you want
832 ;; -- except absolutely not what you want when you're
833 ;; debugging failures in PRINT-OBJECT logic.
834 ;; We try to address all these issues with explicit
836 (*current-level-in-print
* 0)
837 (*package
* original-package
)
838 (*print-pretty
* original-print-pretty
)
839 ;; Clear the circularity machinery to try to to reduce the
840 ;; pain from sharing the circularity table across all
841 ;; streams; if these are not rebound here, then setting
842 ;; *PRINT-CIRCLE* within the debugger when debugging in a
843 ;; state where something circular was being printed (e.g.,
844 ;; because the debugger was entered on an error in a
845 ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
846 ;; here does seem somewhat ugly because it makes it more
847 ;; difficult to debug the printing-of-circularities code
848 ;; itself; however, as far as I (WHN, 2004-05-29) can see,
849 ;; that's almost entirely academic as long as there's one
850 ;; shared *C-H-T* for all streams (i.e., it's already
851 ;; unreasonably difficult to debug print-circle machinery
852 ;; given the buggy crosstalk between the debugger streams
853 ;; and the stream you're trying to watch), and any fix for
854 ;; that buggy arrangement will likely let this hack go away
856 (sb!impl
::*circularity-hash-table
* . nil
)
857 (sb!impl
::*circularity-counter
* . nil
)
858 (*readtable
* *debug-readtable
*))
860 ;; (Why NREVERSE? PROGV makes the later entries have
861 ;; precedence over the earlier entries.
862 ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
863 ;; expected that its earlier entries have precedence. And
864 ;; the earlier-has-precedence behavior is mostly more
865 ;; convenient, so that programmers can use PUSH or LIST* to
866 ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
867 (nreverse (mapcar #'car
*debug-print-variable-alist
*))
868 (nreverse (mapcar #'cdr
*debug-print-variable-alist
*))
869 (apply fun rest
)))))))
871 ;;; This function is not inlined so it shows up in the backtrace; that
872 ;;; can be rather handy when one has to debug the interplay between
873 ;;; *INVOKE-DEBUGGER-HOOK* and *DEBUGGER-HOOK*.
874 (declaim (notinline run-hook
))
875 (defun run-hook (variable condition
)
876 (let ((old-hook (symbol-value variable
)))
878 (progv (list variable
) (list nil
)
879 (funcall old-hook condition old-hook
)))))
881 ;;; We can bind *stack-top-hint* to a symbol, in which case this function will
882 ;;; resolve that hint lazily before we enter the debugger.
883 (defun resolve-stack-top-hint ()
884 (let ((hint *stack-top-hint
*)
885 (*stack-top-hint
* nil
))
887 ;; No hint, just keep the debugger guts out.
890 ;; Interrupted. Look for the interrupted frame -- if we don't find one
891 ;; this falls back to the next case.
892 ((and (eq hint
'invoke-interruption
)
893 (find-interrupted-frame)))
894 ;; Name of the first uninteresting frame.
896 (find-caller-of-named-frame hint
))
897 ;; We already have a resolved hint.
901 (defun invoke-debugger (condition)
902 "Enter the debugger."
903 (let ((*stack-top-hint
* (resolve-stack-top-hint)))
904 ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
905 ;; called when the debugger is disabled
906 (run-hook '*invoke-debugger-hook
* condition
)
907 (run-hook '*debugger-hook
* condition
)
908 ;; We definitely want *PACKAGE* to be of valid type.
910 ;; Elsewhere in the system, we use the SANE-PACKAGE function for
911 ;; this, but here causing an exception just as we're trying to handle
912 ;; an exception would be confusing, so instead we use a special hack.
913 (unless (package-name *package
*)
914 (setf *package
* (find-package :cl-user
))
915 (format *error-output
*
916 "The value of ~S was not an undeleted PACKAGE. It has been ~
918 '*package
* *package
*))
919 ;; Before we start our own output, finish any pending output.
920 ;; Otherwise, if the user tried to track the progress of his program
921 ;; using PRINT statements, he'd tend to lose the last line of output
922 ;; or so, which'd be confusing.
923 (flush-standard-output-streams)
924 (funcall-with-debug-io-syntax #'%invoke-debugger condition
)))
926 (defun %print-debugger-invocation-reason
(condition stream
)
927 (format stream
"~2&")
928 ;; Note: Ordinarily it's only a matter of taste whether to use
929 ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
930 ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
931 ;; definitely preferred, because the FORMAT alternative was acting odd.
932 (pprint-logical-block (stream nil
)
934 "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A"
936 #!+sb-thread sb
!thread
:*current-thread
*
941 (defun %invoke-debugger
(condition)
942 (let ((*debug-condition
* condition
)
943 (*debug-restarts
* (compute-restarts condition
))
944 (*nested-debug-condition
* nil
))
946 ;; (The initial output here goes to *ERROR-OUTPUT*, because the
947 ;; initial output is not interactive, just an error message, and
948 ;; when people redirect *ERROR-OUTPUT*, they could reasonably
949 ;; expect to see error messages logged there, regardless of what
950 ;; the debugger does afterwards.)
951 (unless (typep condition
'step-condition
)
952 (%print-debugger-invocation-reason condition
*error-output
*))
954 (setf *nested-debug-condition
* condition
)
955 (let ((ndc-type (type-of *nested-debug-condition
*)))
956 (format *error-output
*
957 "~&~@<(A ~S was caught when trying to print ~S when ~
958 entering the debugger. Printing was aborted and the ~
959 ~S was stored in ~S.)~@:>~%"
963 '*nested-debug-condition
*))
964 (when (typep *nested-debug-condition
* 'cell-error
)
965 ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
966 (format *error-output
*
967 "~&(CELL-ERROR-NAME ~S) = ~S~%"
968 '*nested-debug-condition
*
969 (cell-error-name *nested-debug-condition
*)))))
971 (let ((background-p (sb!thread
::debugger-wait-until-foreground-thread
974 ;; After the initial error/condition/whatever announcement to
975 ;; *ERROR-OUTPUT*, we become interactive, and should talk on
976 ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
977 ;; statement, not a description of reality.:-| There's a lot of
978 ;; older debugger code which was written to do i/o on whatever
979 ;; stream was in fashion at the time, and not all of it has
980 ;; been converted to behave this way. -- WHN 2000-11-16)
983 (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
984 ;; here as well, but that is probably bogus since it
985 ;; removes the users ability to do output to a redirected
986 ;; *S-O*. Now we just rebind it so that users can temporarily
987 ;; frob it. FIXME: This and other "what gets bound when"
988 ;; behaviour should be documented in the manual.
989 (*standard-output
* *standard-output
*)
990 ;; This seems reasonable: e.g. if the user has redirected
991 ;; *ERROR-OUTPUT* to some log file, it's probably wrong
992 ;; to send errors which occur in interactive debugging to
993 ;; that file, and right to send them to *DEBUG-IO*.
994 (*error-output
* *debug-io
*))
995 (unless (typep condition
'step-condition
)
996 (when *debug-beginner-help-p
*
998 "~%~@<Type HELP for debugger help, or ~
999 (SB-EXT:EXIT) to exit from SBCL.~:@>~2%"))
1000 (show-restarts *debug-restarts
* *debug-io
*))
1003 (sb!thread
::release-foreground
))))))
1005 ;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
1006 ;;; ANSI behavior has been suppressed by the "--disable-debugger"
1007 ;;; command-line option
1008 (defun debugger-disabled-hook (condition previous-hook
)
1009 (declare (ignore previous-hook
))
1010 ;; There is no one there to interact with, so report the
1011 ;; condition and terminate the program.
1012 (let ((*suppress-print-errors
* t
)
1013 (condition-error-message
1014 #.
(format nil
"A nested error within --disable-debugger error ~
1015 handling prevents displaying the original error. Attempting ~
1016 to print a backtrace."))
1017 (backtrace-error-message
1018 #.
(format nil
"A nested error within --disable-debugger error ~
1019 handling prevents printing the backtrace. Sorry, exiting.")))
1021 ((failure-quit (&key abort
)
1022 (/show0
"in FAILURE-QUIT (in --disable-debugger debugger hook)")
1023 (exit :code
1 :abort abort
))
1024 (display-condition ()
1029 ;; printing failed, try to describe it
1030 (describe-condition)))
1032 ;; ok, give up trying to display the error and inform the user about it
1033 (finish-output *error-output
*)
1034 (%primitive print condition-error-message
))))
1036 (format *error-output
*
1037 "~&~@<Unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
1039 #!+sb-thread sb
!thread
:*current-thread
*
1042 (finish-output *error-output
*))
1043 (describe-condition ()
1044 (format *error-output
*
1045 "~&Unhandled ~S~@[ in thread ~S~]:~%"
1047 #!+sb-thread sb
!thread
:*current-thread
*
1049 (describe condition
*error-output
*)
1050 (finish-output *error-output
*))
1051 (display-backtrace ()
1053 (print-backtrace :stream
*error-output
*
1054 :from
:interrupted-frame
1056 :emergency-best-effort t
)
1059 (finish-output *error-output
*)))
1060 ;; This HANDLER-CASE is here mostly to stop output immediately
1061 ;; (and fall through to QUIT) when there's an I/O error. Thus,
1062 ;; when we're run under a shell script or something, we can die
1063 ;; cleanly when the script dies (and our pipes are cut), instead
1064 ;; of falling into ldb or something messy like that. Similarly, we
1065 ;; can terminate cleanly even if BACKTRACE dies because of bugs in
1066 ;; user PRINT-OBJECT methods. Separate the error handling of the
1067 ;; two phases to maximize the chance of emitting some useful
1073 (format *error-output
*
1074 "~%unhandled condition in --disable-debugger mode, quitting~%")
1075 (finish-output *error-output
*)
1078 ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
1079 ;; fail when our output streams are blown away, as e.g. when
1080 ;; we're running under a Unix shell script and it dies somehow
1081 ;; (e.g. because of a SIGINT). In that case, we might as well
1082 ;; just give it up for a bad job, and stop trying to notify
1083 ;; the user of anything.
1085 ;; Actually, the only way I've run across to exercise the
1086 ;; problem is to have more than one layer of shell script.
1087 ;; I have a shell script which does
1088 ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
1089 ;; and the problem occurs when I interrupt this with Ctrl-C
1090 ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
1091 ;; I haven't figured out whether it's bash, time, tee, Linux, or
1092 ;; what that is responsible, but that it's possible at all
1093 ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
1095 (%primitive print backtrace-error-message
))
1096 (failure-quit :abort t
))))))
1098 (defvar *old-debugger-hook
* nil
)
1100 ;;; halt-on-failures and prompt-on-failures modes, suitable for
1101 ;;; noninteractive and interactive use respectively
1102 (defun disable-debugger ()
1103 "When invoked, this function will turn off both the SBCL debugger
1104 and LDB (the low-level debugger). See also ENABLE-DEBUGGER."
1105 ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
1106 ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
1107 ;; to set it to a suitable value again and be very careful,
1108 ;; especially if the user has also set it. -- MG 2005-07-15
1109 (unless (eq *invoke-debugger-hook
* 'debugger-disabled-hook
)
1110 (setf *old-debugger-hook
* *invoke-debugger-hook
*
1111 *invoke-debugger-hook
* 'debugger-disabled-hook
))
1112 ;; This is not inside the UNLESS to ensure that LDB is disabled
1113 ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
1114 ;; This might matter for example when restoring a core.
1115 (sb!alien
:alien-funcall
(sb!alien
:extern-alien
"disable_lossage_handler"
1116 (function sb
!alien
:void
))))
1118 (defun enable-debugger ()
1119 "Restore the debugger if it has been turned off by DISABLE-DEBUGGER."
1120 (when (eql *invoke-debugger-hook
* 'debugger-disabled-hook
)
1121 (setf *invoke-debugger-hook
* *old-debugger-hook
*
1122 *old-debugger-hook
* nil
))
1123 (sb!alien
:alien-funcall
(sb!alien
:extern-alien
"enable_lossage_handler"
1124 (function sb
!alien
:void
))))
1126 (defun show-restarts (restarts s
)
1127 (cond ((null restarts
)
1129 "~&(no restarts: If you didn't do this on purpose, ~
1130 please report it as a bug.)~%"))
1132 (format s
"~&restarts (invokable by number or by ~
1133 possibly-abbreviated name):~%")
1137 (dolist (restart restarts
)
1138 (let ((name (restart-name restart
)))
1140 (let ((len (length (princ-to-string name
))))
1141 (when (> len max-name-len
)
1142 (setf max-name-len len
))))))
1143 (unless (zerop max-name-len
)
1144 (incf max-name-len
3))
1145 (dolist (restart restarts
)
1146 (let ((name (restart-name restart
)))
1147 ;; FIXME: maybe it would be better to display later names
1148 ;; in parens instead of brakets, not just omit them fully.
1149 ;; Call BREAK, call BREAK in the debugger, and tell me
1150 ;; it's not confusing looking. --NS 20050310
1151 (cond ((member name names-used
)
1152 (format s
"~& ~2D: ~V@T~A~%" count max-name-len restart
))
1154 (format s
"~& ~2D: [~VA] ~A~%"
1155 count
(- max-name-len
3) name restart
)
1156 (push name names-used
))))
1159 (defvar *debug-loop-fun
* #'debug-loop-fun
1160 "A function taking no parameters that starts the low-level debug loop.")
1162 ;;; When the debugger is invoked due to a stepper condition, we don't
1163 ;;; want to print the current frame before the first prompt for aesthetic
1165 (defvar *suppress-frame-print
* nil
)
1167 ;;; This calls DEBUG-LOOP, performing some simple initializations
1168 ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
1169 ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
1170 ;;; to get into a debug prompt as quickly as possible with as little
1171 ;;; risk as possible for stepping on whatever is causing recursive
1173 (defun internal-debug ()
1174 (let ((*in-the-debugger
* t
)
1175 (*read-suppress
* nil
))
1176 (unless (typep *debug-condition
* 'step-condition
)
1177 (clear-input *debug-io
*))
1178 (let ((*suppress-frame-print
* (typep *debug-condition
* 'step-condition
)))
1179 (funcall *debug-loop-fun
*))))
1183 ;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
1184 ;;; was motivated by desire to play nicely with ILISP.
1185 (defvar *flush-debug-errors
* nil
1186 "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
1187 executing in the debugger.")
1189 (defun debug-read (stream eof-restart
)
1190 (declare (type stream stream
))
1191 (let* ((eof-marker (cons nil nil
))
1192 (form (read stream nil eof-marker
)))
1193 (if (eq form eof-marker
)
1194 (invoke-restart eof-restart
)
1197 (defun debug-loop-fun ()
1198 (let* ((*debug-command-level
* (1+ *debug-command-level
*))
1199 (*real-stack-top
* (sb!di
:top-frame
))
1200 (*stack-top
* (or *stack-top-hint
* *real-stack-top
*))
1201 (*stack-top-hint
* nil
)
1202 (*current-frame
* *stack-top
*))
1203 (handler-bind ((sb!di
:debug-condition
1205 (princ condition
*debug-io
*)
1206 (/show0
"handling d-c by THROWing DEBUG-LOOP-CATCHER")
1207 (throw 'debug-loop-catcher nil
))))
1208 (cond (*suppress-frame-print
*
1209 (setf *suppress-frame-print
* nil
))
1212 (print-frame-call *current-frame
* *debug-io
* :print-frame-source t
)))
1214 (catch 'debug-loop-catcher
1215 (handler-bind ((error (lambda (condition)
1216 (when *flush-debug-errors
*
1217 (clear-input *debug-io
*)
1218 (princ condition
*debug-io
*)
1220 "~&error flushed (because ~
1222 '*flush-debug-errors
*)
1223 (/show0
"throwing DEBUG-LOOP-CATCHER")
1224 (throw 'debug-loop-catcher nil
)))))
1225 ;; We have to bind LEVEL for the restart function created
1226 ;; by WITH-SIMPLE-RESTART, and we need the explicit ABORT
1227 ;; restart that exists now so that EOF from read can drop
1228 ;; one debugger level.
1229 (let ((level *debug-command-level
*)
1230 (restart-commands (make-restart-commands))
1231 (abort-restart-for-eof (find-restart 'abort
)))
1232 (flush-standard-output-streams)
1233 (debug-prompt *debug-io
*)
1234 (force-output *debug-io
*)
1235 (with-simple-restart (abort
1236 "~@<Reduce debugger level (to debug level ~W).~@:>"
1238 (let* ((exp (debug-read *debug-io
* abort-restart-for-eof
))
1239 (cmd-fun (debug-command-p exp restart-commands
)))
1240 (cond ((not cmd-fun
)
1241 (debug-eval-print exp
))
1244 "~&Your command, ~S, is ambiguous:~%"
1246 (dolist (ele cmd-fun
)
1247 (format *debug-io
* " ~A~%" ele
)))
1249 (funcall cmd-fun
))))))))))))
1251 (defvar *auto-eval-in-frame
* t
1252 "When set (the default), evaluations in the debugger's command loop occur
1253 relative to the current frame's environment without the need of debugger
1254 forms that explicitly control this kind of evaluation.")
1256 (defun debug-eval (expr)
1257 (cond ((not (and (fboundp 'compile
) *auto-eval-in-frame
*))
1259 ((frame-has-debug-vars-p *current-frame
*)
1260 (sb!di
:eval-in-frame
*current-frame
* expr
))
1262 (format *debug-io
* "; No debug variables for current frame: ~
1263 using EVAL instead of EVAL-IN-FRAME.~%")
1266 (defun debug-eval-print (expr)
1267 (/noshow
"entering DEBUG-EVAL-PRINT" expr
)
1268 (let ((values (multiple-value-list
1269 (interactive-eval expr
:eval
#'debug-eval
))))
1270 (/noshow
"done with EVAL in DEBUG-EVAL-PRINT")
1271 (dolist (value values
)
1272 (fresh-line *debug-io
*)
1273 (prin1 value
*debug-io
*)))
1274 (force-output *debug-io
*))
1276 ;;;; debug loop functions
1278 ;;; These commands are functions, not really commands, so that users
1279 ;;; can get their hands on the values returned.
1281 (defun var-valid-in-frame-p (var location
&optional
(frame *current-frame
*))
1282 ;; arg count errors are checked before anything is set up but they
1283 ;; are reporeted in *elsewhere*, which is after start-pc saved in the
1284 ;; debug function, defeating the checks.
1285 (and (not (sb!di
::all-args-available-p frame
))
1286 (eq (sb!di
:debug-var-validity var location
) :valid
)))
1288 (eval-when (:execute
:compile-toplevel
)
1290 (sb!xc
:defmacro define-var-operation
(ref-or-set &optional value-var
)
1291 `(let* ((temp (etypecase name
1292 (symbol (sb!di
:debug-fun-symbol-vars
1293 (sb!di
:frame-debug-fun
*current-frame
*)
1295 (simple-string (sb!di
:ambiguous-debug-vars
1296 (sb!di
:frame-debug-fun
*current-frame
*)
1298 (location (sb!di
:frame-code-location
*current-frame
*))
1299 ;; Let's only deal with valid variables.
1300 (vars (remove-if-not (lambda (v)
1301 (var-valid-in-frame-p v location
))
1303 (declare (list vars
))
1305 (error "No known valid variables match ~S." name
))
1306 ((= (length vars
) 1)
1309 '(sb!di
:debug-var-value
(car vars
) *current-frame
*))
1311 `(setf (sb!di
:debug-var-value
(car vars
) *current-frame
*)
1314 ;; Since we have more than one, first see whether we have
1315 ;; any variables that exactly match the specification.
1316 (let* ((name (etypecase name
1317 (symbol (symbol-name name
))
1318 (simple-string name
)))
1319 ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
1321 (exact (remove-if-not (lambda (v)
1322 (string= (sb!di
:debug-var-symbol-name v
)
1325 (vars (or exact vars
)))
1326 (declare (simple-string name
)
1329 ;; Check now for only having one variable.
1330 ((= (length vars
) 1)
1333 '(sb!di
:debug-var-value
(car vars
) *current-frame
*))
1335 `(setf (sb!di
:debug-var-value
(car vars
) *current-frame
*)
1337 ;; If there weren't any exact matches, flame about
1338 ;; ambiguity unless all the variables have the same
1343 (string= (sb!di
:debug-var-symbol-name v
)
1344 (sb!di
:debug-var-symbol-name
(car vars
))))
1346 (error "specification ambiguous:~%~{ ~A~%~}"
1347 (mapcar #'sb
!di
:debug-var-symbol-name
1349 vars
:test
#'string
=
1350 :key
#'sb
!di
:debug-var-symbol-name
))))
1351 ;; All names are the same, so see whether the user
1352 ;; ID'ed one of them.
1354 (let ((v (find id vars
:key
#'sb
!di
:debug-var-id
)))
1357 "invalid variable ID, ~W: should have been one of ~S"
1359 (mapcar #'sb
!di
:debug-var-id vars
)))
1362 '(sb!di
:debug-var-value v
*current-frame
*))
1364 `(setf (sb!di
:debug-var-value v
*current-frame
*)
1367 (error "Specify variable ID to disambiguate ~S. Use one of ~S."
1369 (mapcar #'sb
!di
:debug-var-id vars
)))))))))
1373 ;;; FIXME: This doesn't work. It would be real nice we could make it
1374 ;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
1375 (defun var (name &optional
(id 0 id-supplied
))
1376 "Return a variable's value if possible. NAME is a simple-string or symbol.
1377 If it is a simple-string, it is an initial substring of the variable's name.
1378 If name is a symbol, it has the same name and package as the variable whose
1379 value this function returns. If the symbol is uninterned, then the variable
1380 has the same name as the symbol, but it has no package.
1382 If name is the initial substring of variables with different names, then
1383 this return no values after displaying the ambiguous names. If name
1384 determines multiple variables with the same name, then you must use the
1385 optional id argument to specify which one you want. If you left id
1386 unspecified, then this returns no values after displaying the distinguishing
1389 The result of this function is limited to the availability of variable
1390 information. This is SETF'able."
1391 (define-var-operation :ref
))
1392 (defun (setf var
) (value name
&optional
(id 0 id-supplied
))
1393 (define-var-operation :set value
))
1395 ;;; This returns the COUNT'th arg as the user sees it from args, the
1396 ;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
1397 ;;; potential DEBUG-VAR from the lambda-list, then the second value is
1398 ;;; T. If this returns a keyword symbol or a value from a rest arg,
1399 ;;; then the second value is NIL.
1401 ;;; FIXME: There's probably some way to merge the code here with
1402 ;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
1403 ;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)
1404 (declaim (ftype (function (index list
)) nth-arg
))
1405 (defun nth-arg (count args
)
1407 (dolist (ele args
(error "The argument specification ~S is out of range."
1409 (lambda-list-element-dispatch ele
1410 :required
((if (zerop n
) (return (values ele t
))))
1411 :optional
((if (zerop n
) (return (values (second ele
) t
))))
1412 :keyword
((cond ((zerop n
)
1413 (return (values (second ele
) nil
)))
1415 (return (values (third ele
) t
)))))
1416 :deleted
((if (zerop n
) (return (values ele t
))))
1417 :rest
((let ((var (second ele
)))
1418 (lambda-var-dispatch var
(sb!di
:frame-code-location
1420 (error "unused &REST argument before n'th argument")
1422 (sb!di
:debug-var-value var
*current-frame
*)
1424 "The argument specification ~S is out of range."
1427 (return-from nth-arg
(values value nil
))
1429 (error "invalid &REST argument before n'th argument")))))
1433 "Return the N'th argument's value if possible. Argument zero is the first
1434 argument in a frame's default printed representation. Count keyword/value
1435 pairs as separate arguments."
1436 (when (sb!di
::all-args-available-p
*current-frame
*)
1438 (early-frame-nth-arg n
*current-frame
*)))
1439 (multiple-value-bind (var lambda-var-p
)
1440 (nth-arg n
(handler-case (sb!di
:debug-fun-lambda-list
1441 (sb!di
:frame-debug-fun
*current-frame
*))
1442 (sb!di
:lambda-list-unavailable
()
1443 (error "No argument values are available."))))
1445 (lambda-var-dispatch var
(sb!di
:frame-code-location
*current-frame
*)
1446 (error "Unused arguments have no values.")
1447 (sb!di
:debug-var-value var
*current-frame
*)
1448 (error "invalid argument value"))
1451 ;;;; machinery for definition of debug loop commands
1453 (defvar *debug-commands
* nil
)
1455 ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
1457 (defmacro !def-debug-command
(name args
&rest body
)
1458 (let ((fun-name (symbolicate name
"-DEBUG-COMMAND")))
1460 (setf *debug-commands
*
1461 (remove ,name
*debug-commands
* :key
#'car
:test
#'string
=))
1462 (defun ,fun-name
,args
1463 (unless *in-the-debugger
*
1464 (error "invoking debugger command while outside the debugger"))
1466 (push (cons ,name
#',fun-name
) *debug-commands
*)
1469 (defun !def-debug-command-alias
(new-name existing-name
)
1470 (let ((pair (assoc existing-name
*debug-commands
* :test
#'string
=)))
1471 (unless pair
(error "unknown debug command name: ~S" existing-name
))
1472 (push (cons new-name
(cdr pair
)) *debug-commands
*))
1475 ;;; This takes a symbol and uses its name to find a debugger command,
1476 ;;; using initial substring matching. It returns the command function
1477 ;;; if form identifies only one command, but if form is ambiguous,
1478 ;;; this returns a list of the command names. If there are no matches,
1479 ;;; this returns nil. Whenever the loop that looks for a set of
1480 ;;; possibilities encounters an exact name match, we return that
1481 ;;; command function immediately.
1482 (defun debug-command-p (form &optional other-commands
)
1483 (if (or (symbolp form
) (integerp form
))
1487 (format nil
"~W" form
)))
1490 (declare (simple-string name
)
1494 ;; Find matching commands, punting if exact match.
1495 (flet ((match-command (ele)
1496 (let* ((str (car ele
))
1497 (str-len (length str
)))
1498 (declare (simple-string str
)
1500 (cond ((< str-len len
))
1502 (when (string= name str
:end1 len
:end2 len
)
1503 (return-from debug-command-p
(cdr ele
))))
1504 ((string= name str
:end1 len
:end2 len
)
1506 (mapc #'match-command
*debug-commands
*)
1507 (mapc #'match-command other-commands
))
1509 ;; Return the right value.
1510 (cond ((not res
) nil
)
1513 (t ; Just return the names.
1514 (do ((cmds res
(cdr cmds
)))
1516 (setf (car cmds
) (caar cmds
))))))))
1518 ;;; Return a list of debug commands (in the same format as
1519 ;;; *DEBUG-COMMANDS*) that invoke each active restart.
1521 ;;; Two commands are made for each restart: one for the number, and
1522 ;;; one for the restart name (unless it's been shadowed by an earlier
1523 ;;; restart of the same name, or it is NIL).
1524 (defun make-restart-commands (&optional
(restarts *debug-restarts
*))
1526 (num 0)) ; better be the same as show-restarts!
1527 (dolist (restart restarts
)
1528 (let ((name (string (restart-name restart
))))
1531 (/show0
"in restart-command closure, about to i-r-i")
1532 (invoke-restart-interactively restart
))))
1533 (push (cons (prin1-to-string num
) restart-fun
) commands
)
1534 (unless (or (null (restart-name restart
))
1535 (find name commands
:key
#'car
:test
#'string
=))
1536 (push (cons name restart-fun
) commands
))))
1540 ;;;; frame-changing commands
1542 (!def-debug-command
"UP" ()
1543 (let ((next (sb!di
:frame-up
*current-frame
*)))
1545 (setf *current-frame
* next
)
1546 (print-frame-call next
*debug-io
*))
1548 (format *debug-io
* "~&Top of stack.")))))
1550 (!def-debug-command
"DOWN" ()
1551 (let ((next (sb!di
:frame-down
*current-frame
*)))
1553 (setf *current-frame
* next
)
1554 (print-frame-call next
*debug-io
*))
1556 (format *debug-io
* "~&Bottom of stack.")))))
1558 (!def-debug-command-alias
"D" "DOWN")
1560 (!def-debug-command
"BOTTOM" ()
1561 (do ((prev *current-frame
* lead
)
1562 (lead (sb!di
:frame-down
*current-frame
*) (sb!di
:frame-down lead
)))
1564 (setf *current-frame
* prev
)
1565 (print-frame-call prev
*debug-io
*))))
1567 (!def-debug-command-alias
"B" "BOTTOM")
1569 (!def-debug-command
"FRAME" (&optional
1570 (n (read-prompting-maybe "frame number: ")))
1571 (setf *current-frame
*
1572 (multiple-value-bind (next-frame-fun limit-string
)
1573 (if (< n
(sb!di
:frame-number
*current-frame
*))
1574 (values #'sb
!di
:frame-up
"top")
1575 (values #'sb
!di
:frame-down
"bottom"))
1576 (do ((frame *current-frame
*))
1577 ((= n
(sb!di
:frame-number frame
))
1579 (let ((next-frame (funcall next-frame-fun frame
)))
1581 (setf frame next-frame
))
1584 "The ~A of the stack was encountered.~%"
1586 (return frame
)))))))
1587 (print-frame-call *current-frame
* *debug-io
*))
1589 (!def-debug-command-alias
"F" "FRAME")
1591 ;;;; commands for entering and leaving the debugger
1593 (!def-debug-command
"TOPLEVEL" ()
1594 (throw 'toplevel-catcher nil
))
1597 (!def-debug-command-alias
"TOP" "TOPLEVEL")
1599 (!def-debug-command
"RESTART" ()
1600 (/show0
"doing RESTART debug-command")
1601 (let ((num (read-if-available :prompt
)))
1602 (when (eq num
:prompt
)
1603 (show-restarts *debug-restarts
* *debug-io
*)
1604 (write-string "restart: " *debug-io
*)
1605 (force-output *debug-io
*)
1606 (setf num
(read *debug-io
*)))
1607 (let ((restart (typecase num
1609 (nth num
*debug-restarts
*))
1611 (find num
*debug-restarts
* :key
#'restart-name
1612 :test
(lambda (sym1 sym2
)
1613 (string= (symbol-name sym1
)
1614 (symbol-name sym2
)))))
1616 (format *debug-io
* "~S is invalid as a restart name.~%"
1618 (return-from restart-debug-command nil
)))))
1619 (/show0
"got RESTART")
1621 (invoke-restart-interactively restart
)
1622 (princ "There is no such restart." *debug-io
*)))))
1624 ;;;; information commands
1626 (!def-debug-command
"HELP" ()
1627 ;; CMU CL had a little toy pager here, but "if you aren't running
1628 ;; ILISP (or a smart windowing system, or something) you deserve to
1629 ;; lose", so we've dropped it in SBCL. However, in case some
1630 ;; desperate holdout is running this on a dumb terminal somewhere,
1631 ;; we tell him where to find the message stored as a string.
1633 "~&~A~2%(The HELP string is stored in ~S.)~%"
1635 '*debug-help-string
*))
1637 (!def-debug-command-alias
"?" "HELP")
1639 (!def-debug-command
"ERROR" ()
1640 (format *debug-io
* "~A~%" *debug-condition
*)
1641 (show-restarts *debug-restarts
* *debug-io
*))
1643 (!def-debug-command
"BACKTRACE" ()
1644 (print-backtrace :count
(read-if-available most-positive-fixnum
)))
1646 (!def-debug-command
"PRINT" ()
1647 (print-frame-call *current-frame
* *debug-io
*))
1649 (!def-debug-command-alias
"P" "PRINT")
1651 (!def-debug-command
"LIST-LOCALS" ()
1652 (let ((d-fun (sb!di
:frame-debug-fun
*current-frame
*)))
1654 (when (typep (sb!di
:debug-fun-name d-fun nil
)
1655 '(cons (eql sb
!interpreter
::.eval.
)))
1656 (let ((env (arg 1)))
1657 (when (typep env
'sb
!interpreter
:basic-env
)
1658 (return-from list-locals-debug-command
1659 (sb!interpreter
:list-locals env
)))))
1660 (if (sb!di
:debug-var-info-available d-fun
)
1661 (let ((*standard-output
* *debug-io
*)
1662 (location (sb!di
:frame-code-location
*current-frame
*))
1663 (prefix (read-if-available nil
))
1668 (dolist (v (sb!di
:ambiguous-debug-vars
1670 (if prefix
(string prefix
) "")))
1672 (when (var-valid-in-frame-p v location
)
1673 (setf any-valid-p t
)
1674 (case (sb!di
::debug-var-info v
)
1676 (setf more-context
(sb!di
:debug-var-value v
*current-frame
*)))
1678 (setf more-count
(sb!di
:debug-var-value v
*current-frame
*)))
1680 (format *debug-io
* "~S~:[#~W~;~*~] = ~S~%"
1681 (sb!di
:debug-var-symbol v
)
1682 (zerop (sb!di
:debug-var-id v
))
1683 (sb!di
:debug-var-id v
)
1684 (sb!di
:debug-var-value v
*current-frame
*))))))
1685 (when (and more-context more-count
)
1686 (format *debug-io
* "~S = ~S~%"
1688 (multiple-value-list (sb!c
:%more-arg-values more-context
0 more-count
))))
1692 "There are no local variables ~@[starting with ~A ~]~
1697 "All variables ~@[starting with ~A ~]currently ~
1698 have invalid values."
1700 (write-line "There is no variable information available."
1703 (!def-debug-command-alias
"L" "LIST-LOCALS")
1705 (!def-debug-command
"SOURCE" ()
1706 (print (code-location-source-form (sb!di
:frame-code-location
*current-frame
*)
1707 (read-if-available 0))
1710 ;;;; source location printing
1712 (defun code-location-source-form (location context
&optional
(errorp t
))
1713 (let* ((start-location (maybe-block-start-location location
))
1714 (form-num (sb!di
:code-location-form-number start-location
)))
1715 (multiple-value-bind (translations form
)
1716 (sb!di
:get-toplevel-form start-location
)
1717 (declare (notinline warn
))
1718 (cond ((< form-num
(length translations
))
1719 (sb!di
:source-path-context form
1720 (svref translations form-num
)
1723 (funcall (if errorp
#'error
#'warn
)
1724 "~@<Bogus form-number: the source file has ~
1725 probably changed too much to cope with.~:@>"))))))
1728 ;;; start single-stepping
1729 (!def-debug-command
"START" ()
1730 (if (typep *debug-condition
* 'step-condition
)
1731 (format *debug-io
* "~&Already single-stepping.~%")
1732 (let ((restart (find-restart 'continue
*debug-condition
*)))
1734 (sb!impl
::enable-stepping
)
1735 (invoke-restart restart
))
1737 (format *debug-io
* "~&Non-continuable error, cannot start stepping.~%"))))))
1739 (defmacro !def-step-command
(command-name restart-name
)
1740 `(!def-debug-command
,command-name
()
1741 (if (typep *debug-condition
* 'step-condition
)
1742 (let ((restart (find-restart ',restart-name
*debug-condition
*)))
1744 (invoke-restart restart
))
1745 (format *debug-io
* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%"))))
1747 (!def-step-command
"STEP" step-into
)
1748 (!def-step-command
"NEXT" step-next
)
1749 (!def-step-command
"STOP" step-continue
)
1751 (!def-debug-command-alias
"S" "STEP")
1752 (!def-debug-command-alias
"N" "NEXT")
1754 (!def-debug-command
"OUT" ()
1755 (if (typep *debug-condition
* 'step-condition
)
1756 (if sb
!impl
::*step-out
*
1757 (let ((restart (find-restart 'step-out
*debug-condition
*)))
1759 (invoke-restart restart
))
1760 (format *debug-io
* "~&OUT can only be used step out of frames that were originally stepped into with STEP.~%"))
1761 (format *debug-io
* "~&Not currently single-stepping. (Use START to activate the single-stepper)~%")))
1763 ;;; miscellaneous commands
1765 (!def-debug-command
"DESCRIBE" ()
1766 (let* ((curloc (sb!di
:frame-code-location
*current-frame
*))
1767 (debug-fun (sb!di
:code-location-debug-fun curloc
))
1768 (function (sb!di
:debug-fun-fun debug-fun
)))
1771 (format *debug-io
* "can't figure out the function for this frame"))))
1773 (!def-debug-command
"SLURP" ()
1774 (loop while
(read-char-no-hang *standard-input
*)))
1776 ;;; RETURN-FROM-FRAME and RESTART-FRAME
1778 (defun unwind-to-frame-and-call (frame thunk
)
1779 #!+unwind-to-frame-and-call-vop
1780 (flet ((sap-int/fixnum
(sap)
1781 ;; On unithreaded X86 *BINDING-STACK-POINTER* and
1782 ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through
1783 ;; some hoops to make these calculated values negative too.
1784 (ash (truly-the (signed-byte #.sb
!vm
:n-word-bits
)
1786 (- sb
!vm
::n-fixnum-tag-bits
))))
1787 ;; To properly unwind the stack, we need three pieces of information:
1788 ;; * The unwind block that should be active after the unwind
1789 ;; * The catch block that should be active after the unwind
1790 ;; * The values that the binding stack pointer should have after the
1792 (let ((block (sap-int/fixnum
(find-enclosing-catch-block frame
)))
1793 (unbind-to (find-binding-stack-pointer frame
)))
1794 ;; This VOP will run the neccessary cleanup forms, reset the fp, and
1795 ;; then call the supplied function.
1796 (sb!vm
::%primitive sb
!vm
::unwind-to-frame-and-call
1797 (sb!di
::frame-pointer frame
)
1798 (find-enclosing-uwp frame
)
1800 ;; Before calling the user-specified
1801 ;; function, we need to restore the binding
1802 ;; stack and the catch block. The unwind block
1803 ;; is taken care of by the VOP.
1804 (sb!vm
::%primitive sb
!vm
::unbind-to-here
1806 (setf sb
!vm
::*current-catch-block
* block
)
1808 #!-unwind-to-frame-and-call-vop
1809 (let ((tag (gensym)))
1810 (sb!di
:replace-frame-catch-tag frame
1811 'sb
!c
:debug-catch-tag
1815 #!+unwind-to-frame-and-call-vop
1816 (defun find-binding-stack-pointer (frame)
1817 (let ((debug-fun (sb!di
:frame-debug-fun frame
)))
1818 (if (eq (sb!di
:debug-fun-kind debug-fun
) :external
)
1819 ;; XEPs do not bind anything, nothing to restore.
1820 ;; But they may call other code through SATISFIES
1821 ;; declaration, check that the interrupt is actually in the XEP.
1822 (and (sb!di
::compiled-frame-escaped frame
)
1823 sb
!kernel
::*interr-current-bsp
*)
1824 (let* ((compiled-debug-fun (and
1825 (typep debug-fun
'sb
!di
::compiled-debug-fun
)
1826 (sb!di
::compiled-debug-fun-compiler-debug-fun debug-fun
)))
1827 (bsp-save-offset (and compiled-debug-fun
1828 (sb!c
::compiled-debug-fun-bsp-save compiled-debug-fun
))))
1829 (when bsp-save-offset
1830 (sb!di
::sub-access-debug-var-slot
(sb!di
::frame-pointer frame
) bsp-save-offset
))))))
1832 (defun find-enclosing-catch-block (frame)
1833 ;; Walk the catch block chain looking for the first entry with an address
1834 ;; higher than the pointer for FRAME or a null pointer.
1835 (let* ((frame-pointer (sb!di
::frame-pointer frame
))
1836 (current-block (int-sap (ldb (byte #.sb
!vm
:n-word-bits
0)
1837 (ash sb
!vm
::*current-catch-block
*
1838 sb
!vm
:n-fixnum-tag-bits
))))
1839 (enclosing-block (loop for block
= current-block
1840 then
(sap-ref-sap block
1841 (* sb
!vm
:catch-block-previous-catch-slot
1842 sb
!vm
::n-word-bytes
))
1843 when
(or (zerop (sap-int block
))
1844 #!+stack-grows-downward-not-upward
1845 (sap> block frame-pointer
)
1846 #!-stack-grows-downward-not-upward
1847 (sap< block frame-pointer
))
1851 (defun find-enclosing-uwp (frame)
1852 ;; Walk the UWP chain looking for the first entry with an address
1853 ;; higher than the pointer for FRAME or a null pointer.
1854 (let* ((frame-pointer (sb!di
::frame-pointer frame
))
1855 (current-uwp (int-sap (ldb (byte #.sb
!vm
:n-word-bits
0)
1856 (ash sb
!vm
::*current-unwind-protect-block
*
1857 sb
!vm
:n-fixnum-tag-bits
))))
1858 (enclosing-uwp (loop for uwp-block
= current-uwp
1859 then
(sap-ref-sap uwp-block
1860 sb
!vm
:unwind-block-uwp-slot
)
1861 when
(or (zerop (sap-int uwp-block
))
1862 #!+stack-grows-downward-not-upward
1863 (sap> uwp-block frame-pointer
)
1864 #!-stack-grows-downward-not-upward
1865 (sap< uwp-block frame-pointer
))
1869 (!def-debug-command
"RETURN" (&optional
1870 (return (read-prompting-maybe
1872 (if (frame-has-debug-tag-p *current-frame
*)
1873 (let* ((code-location (sb!di
:frame-code-location
*current-frame
*))
1874 (values (multiple-value-list
1875 (funcall (sb!di
:preprocess-for-eval return code-location
)
1877 (unwind-to-frame-and-call *current-frame
* (lambda ()
1878 (values-list values
))))
1880 "~@<can't find a tag for this frame ~
1881 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1882 and recompiling)~:@>")))
1884 (!def-debug-command
"RESTART-FRAME" ()
1885 (if (frame-has-debug-tag-p *current-frame
*)
1886 (multiple-value-bind (fname args
) (frame-call *current-frame
*)
1887 (multiple-value-bind (fun arglist ok
)
1888 (if (and (legal-fun-name-p fname
) (fboundp fname
))
1889 (values (fdefinition fname
) args t
)
1890 (values (sb!di
:debug-fun-fun
(sb!di
:frame-debug-fun
*current-frame
*))
1891 (frame-args-as-list *current-frame
*)
1895 (y-or-n-p "~@<No global function for the frame, but we ~
1896 do have access to a function object that we ~
1897 can try to call -- but if it is normally part ~
1898 of a closure, then this is NOT going to end well.~_~_~
1899 Try it anyways?~:@>")))
1900 (unwind-to-frame-and-call *current-frame
*
1903 (declare (optimize (debug 0)))
1904 (apply fun arglist
))))
1906 "Can't restart ~S: no function for frame."
1909 "~@<Can't restart ~S: tag not found. ~
1910 ~2I~_(hint: try increasing the DEBUG optimization quality ~
1911 and recompiling)~:@>"
1914 (defun frame-has-debug-tag-p (frame)
1915 #!+unwind-to-frame-and-call-vop
1916 ;; XEPs do not bind anything, nothing to restore
1917 (find-binding-stack-pointer frame
)
1918 #!-unwind-to-frame-and-call-vop
1919 (find 'sb
!c
:debug-catch-tag
(sb!di
::frame-catches frame
) :key
#'car
))
1921 (defun frame-has-debug-vars-p (frame)
1922 (sb!di
:debug-var-info-available
1923 (sb!di
:code-location-debug-fun
1924 (sb!di
:frame-code-location frame
))))
1926 ;;;; debug loop command utilities
1928 (defun read-prompting-maybe (prompt)
1929 (unless (sb!int
:listen-skip-whitespace
*debug-io
*)
1930 (princ prompt
*debug-io
*)
1931 (force-output *debug-io
*))
1934 (defun read-if-available (default)
1935 (if (sb!int
:listen-skip-whitespace
*debug-io
*)