src/code/debug.lisp

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