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