src/code/debug.lisp

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