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