src/code/debug.lisp

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