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-level* 5
  35   #!+sb-doc
  36   "*PRINT-LEVEL* for the debugger")
  37 (defvar *debug-print-length* 7
  38   #!+sb-doc
  39   "*PRINT-LENGTH* for the debugger")
  40
  41 (defvar *debug-readtable*
  42   ;; KLUDGE: This can't be initialized in a cold toplevel form,
  43   ;; because the *STANDARD-READTABLE* isn't initialized until after
  44   ;; cold toplevel forms have run. So instead we initialize it
  45   ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
  46   nil
  47   #!+sb-doc
  48   "*READTABLE* for the debugger")
  49
  50 (defvar *in-the-debugger* nil
  51   #!+sb-doc
  52   "This is T while in the debugger.")
  53
  54 ;;; nestedness inside debugger command loops
  55 (defvar *debug-command-level* 0)
  56
  57 ;;; If this is bound before the debugger is invoked, it is used as the
  58 ;;; stack top by the debugger.
  59 (defvar *stack-top-hint* nil)
  60
  61 (defvar *stack-top* nil)
  62 (defvar *real-stack-top* nil)
  63
  64 (defvar *current-frame* nil)
  65
  66 ;;; Beginner-oriented help messages are important because you end up
  67 ;;; in the debugger whenever something bad happens, or if you try to
  68 ;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
  69 ;;; But after memorizing them the wasted screen space gets annoying..
  70 (defvar *debug-beginner-help-p* t
  71   "Should the debugger display beginner-oriented help messages?")
  72
  73 (defun debug-prompt (stream)
  74   (format stream
  75           "~%~W~:[~;[~W~]] "
  76           (sb!di:frame-number *current-frame*)
  77           (> *debug-command-level* 1)
  78           *debug-command-level*))
  79
  80 (defparameter *debug-help-string*
  81 "The prompt is right square brackets, the number indicating how many
  82   recursive command loops you are in.
  83 Any command may be uniquely abbreviated.
  84 The debugger rebinds various special variables for controlling i/o, sometimes
  85   to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
  86   its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.
  87 Debug commands do not affect * and friends, but evaluation in the debug loop
  88   does affect these variables.
  89 SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
  90   drop you into deeper into the debugger.
  91
  92 Getting in and out of the debugger:
  93   RESTART  invokes restart numbered as shown (prompt if not given).
  94   ERROR    prints the error condition and restart cases.
  95   The name of any restart, or its number, is a valid command, and is the same
  96     as using RESTART to invoke that restart.
  97
  98 Changing frames:
  99   U      up frame     D    down frame
 100   B  bottom frame     F n  frame n (n=0 for top frame)
 101
 102 Inspecting frames:
 103   BACKTRACE [n]  shows n frames going down the stack.
 104   LIST-LOCALS, L lists locals in current function.
 105   PRINT, P       displays current function call.
 106   SOURCE [n]     displays frame's source form with n levels of enclosing forms.
 107
 108 Breakpoints and steps:
 109   LIST-LOCATIONS [{function | :C}]   List the locations for breakpoints.
 110                                      Specify :C for the current frame.
 111     Abbreviation: LL
 112   LIST-BREAKPOINTS                   List the active breakpoints.
 113     Abbreviations: LB, LBP
 114   DELETE-BREAKPOINT [n]              Remove breakpoint n or all breakpoints.
 115     Abbreviations: DEL, DBP
 116   BREAKPOINT {n | :end | :start} [:break form] [:function function]
 117              [{:print form}*] [:condition form]
 118                                      Set a breakpoint.
 119     Abbreviations: BR, BP
 120   STEP [n]                           Step to the next location or step n times.
 121
 122 Function and macro commands:
 123  (SB-DEBUG:DEBUG-RETURN expression)
 124     Exit the debugger, returning expression's values from the current frame.
 125  (SB-DEBUG:ARG n)
 126     Return the n'th argument in the current frame.
 127  (SB-DEBUG:VAR string-or-symbol [id])
 128     Returns the value of the specified variable in the current frame.
 129
 130 Other commands:
 131   SLURP   Discard all pending input on *STANDARD-INPUT*. (This can be
 132           useful when the debugger was invoked to handle an error in
 133           deeply nested input syntax, and now the reader is confused.)")
 134 \f
 135 ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
 136 (define-condition step-condition (simple-condition) ())
 137 \f
 138 ;;;; breakpoint state
 139
 140 (defvar *only-block-start-locations* nil
 141   #!+sb-doc
 142   "When true, the LIST-LOCATIONS command only displays block start locations.
 143    Otherwise, all locations are displayed.")
 144
 145 (defvar *print-location-kind* nil
 146   #!+sb-doc
 147   "When true, list the code location type in the LIST-LOCATIONS command.")
 148
 149 ;;; a list of the types of code-locations that should not be stepped
 150 ;;; to and should not be listed when listing breakpoints
 151 (defvar *bad-code-location-types* '(:call-site :internal-error))
 152 (declaim (type list *bad-code-location-types*))
 153
 154 ;;; code locations of the possible breakpoints
 155 (defvar *possible-breakpoints*)
 156 (declaim (type list *possible-breakpoints*))
 157
 158 ;;; a list of the made and active breakpoints, each is a
 159 ;;; BREAKPOINT-INFO structure
 160 (defvar *breakpoints* nil)
 161 (declaim (type list *breakpoints*))
 162
 163 ;;; a list of BREAKPOINT-INFO structures of the made and active step
 164 ;;; breakpoints
 165 (defvar *step-breakpoints* nil)
 166 (declaim (type list *step-breakpoints*))
 167
 168 ;;; the number of times left to step
 169 (defvar *number-of-steps* 1)
 170 (declaim (type integer *number-of-steps*))
 171
 172 ;;; This is used when listing and setting breakpoints.
 173 (defvar *default-breakpoint-debug-fun* nil)
 174 (declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*))
 175 \f
 176 ;;;; code location utilities
 177
 178 ;;; Return the first code-location in the passed debug block.
 179 (defun first-code-location (debug-block)
 180   (let ((found nil)
 181         (first-code-location nil))
 182     (sb!di:do-debug-block-locations (code-location debug-block)
 183       (unless found
 184         (setf first-code-location code-location)
 185         (setf found t)))
 186     first-code-location))
 187
 188 ;;; Return a list of the next code-locations following the one passed.
 189 ;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned.
 190 (defun next-code-locations (code-location)
 191   (let ((debug-block (sb!di:code-location-debug-block code-location))
 192         (block-code-locations nil))
 193     (sb!di:do-debug-block-locations (block-code-location debug-block)
 194       (unless (member (sb!di:code-location-kind block-code-location)
 195                       *bad-code-location-types*)
 196         (push block-code-location block-code-locations)))
 197     (setf block-code-locations (nreverse block-code-locations))
 198     (let* ((code-loc-list (rest (member code-location block-code-locations
 199                                         :test #'sb!di:code-location=)))
 200            (next-list (cond (code-loc-list
 201                              (list (first code-loc-list)))
 202                             ((map 'list #'first-code-location
 203                                   (sb!di:debug-block-successors debug-block)))
 204                             (t nil))))
 205       (when (and (= (length next-list) 1)
 206                  (sb!di:code-location= (first next-list) code-location))
 207         (setf next-list (next-code-locations (first next-list))))
 208       next-list)))
 209
 210 ;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN.
 211 (defun possible-breakpoints (debug-fun)
 212   (let ((possible-breakpoints nil))
 213     (sb!di:do-debug-fun-blocks (debug-block debug-fun)
 214       (unless (sb!di:debug-block-elsewhere-p debug-block)
 215         (if *only-block-start-locations*
 216             (push (first-code-location debug-block) possible-breakpoints)
 217             (sb!di:do-debug-block-locations (code-location debug-block)
 218               (when (not (member (sb!di:code-location-kind code-location)
 219                                  *bad-code-location-types*))
 220                 (push code-location possible-breakpoints))))))
 221     (nreverse possible-breakpoints)))
 222
 223 ;;; Search the info-list for the item passed (CODE-LOCATION,
 224 ;;; DEBUG-FUN, or BREAKPOINT-INFO). If the item passed is a debug
 225 ;;; function then kind will be compared if it was specified. The kind
 226 ;;; if also compared if a breakpoint-info is passed since it's in the
 227 ;;; breakpoint. The info structure is returned if found.
 228 (defun location-in-list (place info-list &optional (kind nil))
 229   (when (breakpoint-info-p place)
 230     (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
 231     (setf place (breakpoint-info-place place)))
 232   (cond ((sb!di:code-location-p place)
 233          (find place info-list
 234                :key #'breakpoint-info-place
 235                :test (lambda (x y) (and (sb!di:code-location-p y)
 236                                         (sb!di:code-location= x y)))))
 237         (t
 238          (find place info-list
 239                :test (lambda (x-debug-fun y-info)
 240                        (let ((y-place (breakpoint-info-place y-info))
 241                              (y-breakpoint (breakpoint-info-breakpoint
 242                                             y-info)))
 243                          (and (sb!di:debug-fun-p y-place)
 244                               (eq x-debug-fun y-place)
 245                               (or (not kind)
 246                                   (eq kind (sb!di:breakpoint-kind
 247                                             y-breakpoint))))))))))
 248
 249 ;;; If LOC is an unknown location, then try to find the block start
 250 ;;; location. Used by source printing to some information instead of
 251 ;;; none for the user.
 252 (defun maybe-block-start-location (loc)
 253   (if (sb!di:code-location-unknown-p loc)
 254       (let* ((block (sb!di:code-location-debug-block loc))
 255              (start (sb!di:do-debug-block-locations (loc block)
 256                       (return loc))))
 257         (cond ((and (not (sb!di:debug-block-elsewhere-p block))
 258                     start)
 259                ;; FIXME: Why output on T instead of *DEBUG-FOO* or something?
 260                (format t "~%unknown location: using block start~%")
 261                start)
 262               (t
 263                loc)))
 264       loc))
 265 \f
 266 ;;;; the BREAKPOINT-INFO structure
 267
 268 ;;; info about a made breakpoint
 269 (defstruct (breakpoint-info (:copier nil))
 270   ;; where we are going to stop
 271   (place (missing-arg)   :type (or sb!di:code-location sb!di:debug-fun))
 272   ;; the breakpoint returned by sb!di:make-breakpoint
 273   (breakpoint (missing-arg) :type sb!di:breakpoint)
 274   ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
 275   ;; non-NIL, drop into the debugger.
 276   (break #'identity :type function)
 277   ;; the function returned from sb!di:preprocess-for-eval. If result is
 278   ;; non-NIL, eval (each) print and print results.
 279   (condition #'identity :type function)
 280   ;; the list of functions from sb!di:preprocess-for-eval to evaluate.
 281   ;; Results are conditionally printed. Car of each element is the
 282   ;; function, cdr is the form it goes with.
 283   (print nil :type list)
 284   ;; the number used when listing the possible breakpoints within a
 285   ;; function. Could also be a symbol such as start or end.
 286   (code-location-number (missing-arg) :type (or symbol integer))
 287   ;; the number used when listing the breakpoints active and to delete
 288   ;; breakpoints
 289   (breakpoint-number (missing-arg) :type integer))
 290
 291 ;;; Return a new BREAKPOINT-INFO structure with the info passed.
 292 (defun create-breakpoint-info (place breakpoint code-location-number
 293                                      &key (break #'identity)
 294                                      (condition #'identity) (print nil))
 295   (setf *breakpoints*
 296         (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
 297   (let ((breakpoint-number
 298          (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
 299              ((or (> i (length *breakpoints*))
 300                   (not (= i (breakpoint-info-breakpoint-number
 301                              (first breakpoints)))))
 302
 303               i))))
 304     (make-breakpoint-info :place place :breakpoint breakpoint
 305                           :code-location-number code-location-number
 306                           :breakpoint-number breakpoint-number
 307                           :break break :condition condition :print print)))
 308
 309 ;;; Print the breakpoint info for the breakpoint-info structure passed.
 310 (defun print-breakpoint-info (breakpoint-info)
 311   (let ((place (breakpoint-info-place breakpoint-info))
 312         (bp-number (breakpoint-info-breakpoint-number breakpoint-info))
 313         (loc-number (breakpoint-info-code-location-number breakpoint-info)))
 314     (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
 315       (:code-location
 316        (print-code-location-source-form place 0)
 317        (format t
 318                "~&~S: ~S in ~S"
 319                bp-number
 320                loc-number
 321                (sb!di:debug-fun-name (sb!di:code-location-debug-fun
 322                                       place))))
 323       (:fun-start
 324        (format t "~&~S: FUN-START in ~S" bp-number
 325                (sb!di:debug-fun-name place)))
 326       (:fun-end
 327        (format t "~&~S: FUN-END in ~S" bp-number
 328                (sb!di:debug-fun-name place))))))
 329 \f
 330 ;;;; MAIN-HOOK-FUN for steps and breakpoints
 331
 332 ;;; This must be passed as the hook function. It keeps track of where
 333 ;;; STEP breakpoints are.
 334 (defun main-hook-fun (current-frame breakpoint &optional return-vals
 335                                     fun-end-cookie)
 336   (setf *default-breakpoint-debug-fun*
 337         (sb!di:frame-debug-fun current-frame))
 338   (dolist (step-info *step-breakpoints*)
 339     (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info))
 340     (let ((bp-info (location-in-list step-info *breakpoints*)))
 341       (when bp-info
 342         (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
 343   (let ((*stack-top-hint* current-frame)
 344         (step-hit-info
 345          (location-in-list (sb!di:breakpoint-what breakpoint)
 346                            *step-breakpoints*
 347                            (sb!di:breakpoint-kind breakpoint)))
 348         (bp-hit-info
 349          (location-in-list (sb!di:breakpoint-what breakpoint)
 350                            *breakpoints*
 351                            (sb!di:breakpoint-kind breakpoint)))
 352         (break)
 353         (condition)
 354         (string ""))
 355     (setf *step-breakpoints* nil)
 356     (labels ((build-string (str)
 357                (setf string (concatenate 'string string str)))
 358              (print-common-info ()
 359                (build-string
 360                 (with-output-to-string (*standard-output*)
 361                   (when fun-end-cookie
 362                     (format t "~%Return values: ~S" return-vals))
 363                   (when condition
 364                     (when (breakpoint-info-print bp-hit-info)
 365                       (format t "~%")
 366                       (print-frame-call current-frame))
 367                     (dolist (print (breakpoint-info-print bp-hit-info))
 368                       (format t "~& ~S = ~S" (rest print)
 369                               (funcall (first print) current-frame))))))))
 370       (when bp-hit-info
 371         (setf break (funcall (breakpoint-info-break bp-hit-info)
 372                              current-frame))
 373         (setf condition (funcall (breakpoint-info-condition bp-hit-info)
 374                                  current-frame)))
 375       (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
 376              (build-string (format nil "~&*Step (to a breakpoint)*"))
 377              (print-common-info)
 378              (break string))
 379             ((and bp-hit-info step-hit-info break)
 380              (build-string (format nil "~&*Step (to a breakpoint)*"))
 381              (print-common-info)
 382              (break string))
 383             ((and bp-hit-info step-hit-info)
 384              (print-common-info)
 385              (format t "~A" string)
 386              (decf *number-of-steps*)
 387              (set-step-breakpoint current-frame))
 388             ((and step-hit-info (= 1 *number-of-steps*))
 389              (build-string "*Step*")
 390              (break (make-condition 'step-condition :format-control string)))
 391             (step-hit-info
 392              (decf *number-of-steps*)
 393              (set-step-breakpoint current-frame))
 394             (bp-hit-info
 395              (when break
 396                (build-string (format nil "~&*Breakpoint hit*")))
 397              (print-common-info)
 398              (if break
 399                  (break string)
 400                  (format t "~A" string)))
 401             (t
 402              (break "unknown breakpoint"))))))
 403 \f
 404 ;;; Set breakpoints at the next possible code-locations. After calling
 405 ;;; this, either (CONTINUE) if in the debugger or just let program flow
 406 ;;; return if in a hook function.
 407 (defun set-step-breakpoint (frame)
 408   (cond
 409    ((sb!di:debug-block-elsewhere-p (sb!di:code-location-debug-block
 410                                     (sb!di:frame-code-location frame)))
 411     ;; FIXME: FORMAT T is used for error output here and elsewhere in
 412     ;; the debug code.
 413     (format t "cannot step, in elsewhere code~%"))
 414    (t
 415     (let* ((code-location (sb!di:frame-code-location frame))
 416            (next-code-locations (next-code-locations code-location)))
 417       (cond
 418        (next-code-locations
 419         (dolist (code-location next-code-locations)
 420           (let ((bp-info (location-in-list code-location *breakpoints*)))
 421             (when bp-info
 422               (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
 423                                             bp-info))))
 424           (let ((bp (sb!di:make-breakpoint #'main-hook-fun code-location
 425                                            :kind :code-location)))
 426             (sb!di:activate-breakpoint bp)
 427             (push (create-breakpoint-info code-location bp 0)
 428                   *step-breakpoints*))))
 429        (t
 430         (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
 431                (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
 432                                           :kind :fun-end)))
 433           (sb!di:activate-breakpoint bp)
 434           (push (create-breakpoint-info debug-fun bp 0)
 435                 *step-breakpoints*))))))))
 436 \f
 437 ;;;; STEP
 438
 439 ;;; ANSI specifies that this macro shall exist, even if only as a
 440 ;;; trivial placeholder like this.
 441 (defmacro step (form)
 442   "a trivial placeholder implementation of the CL:STEP macro required by
 443    the ANSI spec"
 444   `(progn
 445      ,form))
 446 \f
 447 ;;;; BACKTRACE
 448
 449 (defun backtrace (&optional (count most-positive-fixnum)
 450                             (*standard-output* *debug-io*))
 451   #!+sb-doc
 452   "Show a listing of the call stack going down from the current frame. In the
 453    debugger, the current frame is indicated by the prompt. COUNT is how many
 454    frames to show."
 455   (fresh-line *standard-output*)
 456   (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
 457               (sb!di:frame-down frame))
 458        (count count (1- count)))
 459       ((or (null frame) (zerop count)))
 460     (print-frame-call frame :number t))
 461   (fresh-line *standard-output*)
 462   (values))
 463 \f
 464 ;;;; frame printing
 465
 466 (eval-when (:compile-toplevel :execute)
 467
 468 ;;; This is a convenient way to express what to do for each type of
 469 ;;; lambda-list element.
 470 (sb!xc:defmacro lambda-list-element-dispatch (element
 471                                               &key
 472                                               required
 473                                               optional
 474                                               rest
 475                                               keyword
 476                                               deleted)
 477   `(etypecase ,element
 478      (sb!di:debug-var
 479       ,@required)
 480      (cons
 481       (ecase (car ,element)
 482         (:optional ,@optional)
 483         (:rest ,@rest)
 484         (:keyword ,@keyword)))
 485      (symbol
 486       (aver (eq ,element :deleted))
 487       ,@deleted)))
 488
 489 (sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
 490   (let ((var (gensym)))
 491     `(let ((,var ,variable))
 492        (cond ((eq ,var :deleted) ,deleted)
 493              ((eq (sb!di:debug-var-validity ,var ,location) :valid)
 494               ,valid)
 495              (t ,other)))))
 496
 497 ) ; EVAL-WHEN
 498
 499 ;;; This is used in constructing arg lists for debugger printing when
 500 ;;; the arg list is unavailable, some arg is unavailable or unused, etc.
 501 (defstruct (unprintable-object
 502             (:constructor make-unprintable-object (string))
 503             (:print-object (lambda (x s)
 504                              (print-unreadable-object (x s)
 505                                (write-string (unprintable-object-string x)
 506                                              s))))
 507             (:copier nil))
 508   string)
 509
 510 ;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
 511 ;;; print as many of the values as possible, punting the loop over
 512 ;;; lambda-list variables since any other arguments will be in the
 513 ;;; &REST arg's list of values.
 514 (defun print-frame-call-1 (frame)
 515   (let ((debug-fun (sb!di:frame-debug-fun frame))
 516         (loc (sb!di:frame-code-location frame))
 517         (reversed-args nil))
 518
 519     ;; Construct function arguments in REVERSED-ARGS.
 520     (handler-case
 521         (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
 522           (lambda-list-element-dispatch ele
 523             :required ((push (frame-call-arg ele loc frame) reversed-args))
 524             :optional ((push (frame-call-arg (second ele) loc frame)
 525                              reversed-args))
 526             :keyword ((push (second ele) reversed-args)
 527                       (push (frame-call-arg (third ele) loc frame)
 528                             reversed-args))
 529             :deleted ((push (frame-call-arg ele loc frame) reversed-args))
 530             :rest ((lambda-var-dispatch (second ele) loc
 531                      nil
 532                      (progn
 533                        (setf reversed-args
 534                              (append (reverse (sb!di:debug-var-value
 535                                                (second ele) frame))
 536                                      reversed-args))
 537                        (return))
 538                      (push (make-unprintable-object
 539                             "unavailable &REST argument")
 540                            reversed-args)))))
 541       (sb!di:lambda-list-unavailable
 542        ()
 543        (push (make-unprintable-object "lambda list unavailable")
 544              reversed-args)))
 545
 546     (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
 547       (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args))))
 548         ;; Since we go to some trouble to make nice informative function
 549         ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
 550         ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
 551         (let ((*print-length* nil)
 552               (*print-level* nil))
 553           (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
 554         ;; For the function arguments, we can just print normally.
 555         (format t "~{ ~_~S~}" args)))
 556
 557     (when (sb!di:debug-fun-kind debug-fun)
 558       (write-char #\[)
 559       (prin1 (sb!di:debug-fun-kind debug-fun))
 560       (write-char #\]))))
 561
 562 (defun ensure-printable-object (object)
 563   (handler-case
 564       (with-open-stream (out (make-broadcast-stream))
 565         (prin1 object out)
 566         object)
 567     (error (cond)
 568       (declare (ignore cond))
 569       (make-unprintable-object "error printing object"))))
 570
 571 (defun frame-call-arg (var location frame)
 572   (lambda-var-dispatch var location
 573     (make-unprintable-object "unused argument")
 574     (sb!di:debug-var-value var frame)
 575     (make-unprintable-object "unavailable argument")))
 576
 577 ;;; Prints a representation of the function call causing FRAME to
 578 ;;; exist. VERBOSITY indicates the level of information to output;
 579 ;;; zero indicates just printing the DEBUG-FUN's name, and one
 580 ;;; indicates displaying call-like, one-liner format with argument
 581 ;;; values.
 582 (defun print-frame-call (frame &key (verbosity 1) (number nil))
 583   (cond
 584    ((zerop verbosity)
 585     (when number
 586       (format t "~&~S: " (sb!di:frame-number frame)))
 587     (format t "~S" frame))
 588    (t
 589     (when number
 590       (format t "~&~S: " (sb!di:frame-number frame)))
 591     (print-frame-call-1 frame)))
 592   (when (>= verbosity 2)
 593     (let ((loc (sb!di:frame-code-location frame)))
 594       (handler-case
 595           (progn
 596             (sb!di:code-location-debug-block loc)
 597             (format t "~%source: ")
 598             (print-code-location-source-form loc 0))
 599         (sb!di:debug-condition (ignore) ignore)
 600         (error (c) (format t "error finding source: ~A" c))))))
 601 \f
 602 ;;;; INVOKE-DEBUGGER
 603
 604 (defvar *debugger-hook* nil
 605   #!+sb-doc
 606   "This is either NIL or a function of two arguments, a condition and the value
 607    of *DEBUGGER-HOOK*. This function can either handle the condition or return
 608    which causes the standard debugger to execute. The system passes the value
 609    of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
 610    around the invocation.")
 611
 612 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
 613 (defvar *debug-restarts*)
 614 (defvar *debug-condition*)
 615 (defvar *nested-debug-condition*)
 616
 617 (defun invoke-debugger (condition)
 618   #!+sb-doc
 619   "Enter the debugger."
 620   (let ((old-hook *debugger-hook*))
 621     (when old-hook
 622       (let ((*debugger-hook* nil))
 623         (funcall old-hook condition old-hook))))
 624   ;; FIXME: No-one seems to know what this is for. Nothing is noticeably
 625   ;; broken on sunos...
 626   #!-sunos (sb!unix:unix-sigsetmask 0)
 627
 628   ;; Elsewhere in the system, we use the SANE-PACKAGE function for
 629   ;; this, but here causing an exception just as we're trying to handle
 630   ;; an exception would be confusing, so instead we use a special hack.
 631   (unless (and (packagep *package*)
 632                (package-name *package*))
 633     (setf *package* (find-package :cl-user))
 634     (format *error-output*
 635             "The value of ~S was not an undeleted PACKAGE. It has been
 636 reset to ~S."
 637             '*package* *package*))
 638   (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX.
 639         (original-package *package*))
 640     (with-standard-io-syntax
 641      (let* ((*debug-condition* condition)
 642             (*debug-restarts* (compute-restarts condition))
 643             ;; We want the i/o subsystem to be in a known, useful
 644             ;; state, regardless of where the debugger was invoked in
 645             ;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
 646             ;; but
 647             ;;   1. It doesn't affect our internal special variables
 648             ;;      like *CURRENT-LEVEL-IN-PRINT*.
 649             ;;   2. It isn't customizable.
 650             ;;   3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
 651             ;;      to the same value as the toplevel default.
 652             ;;   4. It sets *PACKAGE* to COMMON-LISP-USER, which is not
 653             ;;      helpful behavior for a debugger.
 654             ;; We try to remedy all these problems with explicit
 655             ;; rebindings here.
 656             (sb!kernel:*current-level-in-print* 0)
 657             (*print-length* *debug-print-length*)
 658             (*print-level* *debug-print-level*)
 659             (*readtable* *debug-readtable*)
 660             (*print-readably* nil)
 661             (*print-pretty* t)
 662             (*package* original-package)
 663             (*nested-debug-condition* nil))
 664
 665        ;; Before we start our own output, finish any pending output.
 666        ;; Otherwise, if the user tried to track the progress of
 667        ;; his program using PRINT statements, he'd tend to lose
 668        ;; the last line of output or so, and get confused.
 669        (flush-standard-output-streams)
 670
 671        ;; (The initial output here goes to *ERROR-OUTPUT*, because the
 672        ;; initial output is not interactive, just an error message,
 673        ;; and when people redirect *ERROR-OUTPUT*, they could
 674        ;; reasonably expect to see error messages logged there,
 675        ;; regardless of what the debugger does afterwards.)
 676        (handler-case
 677            (format *error-output*
 678                    "~2&~@<debugger invoked on condition of type ~S: ~
 679                     ~2I~_~A~:>~%"
 680                    (type-of *debug-condition*)
 681                    *debug-condition*)
 682          (error (condition)
 683            (setf *nested-debug-condition* condition)
 684            (let ((ndc-type (type-of *nested-debug-condition*)))
 685              (format *error-output*
 686                      "~&~@<(A ~S was caught when trying to print ~S when ~
 687                       entering the debugger. Printing was aborted and the ~
 688                       ~S was stored in ~S.)~@:>~%"
 689                      ndc-type
 690                      '*debug-condition*
 691                      ndc-type
 692                      '*nested-debug-condition*))
 693            (when (typep condition 'cell-error)
 694              ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
 695              (format *error-output*
 696                      "~&(CELL-ERROR-NAME ~S) = ~S~%"
 697                      '*debug-condition*
 698                      (cell-error-name *debug-condition*)))))
 699
 700        ;; After the initial error/condition/whatever announcement to
 701        ;; *ERROR-OUTPUT*, we become interactive, and should talk on
 702        ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
 703        ;; statement, not a description of reality.:-| There's a lot of
 704        ;; older debugger code which was written to do i/o on whatever
 705        ;; stream was in fashion at the time, and not all of it has
 706        ;; been converted to behave this way. -- WHN 2000-11-16)
 707        (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
 708              ;; violating the principle of least surprise, and making
 709              ;; it impossible for the user to do reasonable things
 710              ;; like using PRINT at the debugger prompt to send output
 711              ;; to the program's ordinary (possibly
 712              ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
 713              ;; used to rebind *STANDARD-INPUT* here too, but that's
 714              ;; been fixed already.)
 715              (*standard-output* *debug-io*)
 716              ;; This seems reasonable: e.g. if the user has redirected
 717              ;; *ERROR-OUTPUT* to some log file, it's probably wrong
 718              ;; to send errors which occur in interactive debugging to
 719              ;; that file, and right to send them to *DEBUG-IO*.
 720              (*error-output* *debug-io*))
 721          (unless (typep condition 'step-condition)
 722            (when *debug-beginner-help-p*
 723              (format *debug-io*
 724                      "~%~@<Within the debugger, you can type HELP for help. ~
 725                       At any command prompt (within the debugger or not) you ~
 726                       can type (SB-EXT:QUIT) to terminate the SBCL ~
 727                       executable. The condition which caused the debugger to ~
 728                       be entered is bound to ~S. You can suppress this ~
 729                       message by clearing ~S.~:@>~2%"
 730                      '*debug-condition*
 731                      '*debug-beginner-help-p*))
 732            (show-restarts *debug-restarts* *debug-io*))
 733          (internal-debug))))))
 734
 735 (defun show-restarts (restarts s)
 736   (cond ((null restarts)
 737          (format s
 738                  "~&(no restarts: If you didn't do this on purpose, ~
 739                   please report it as a bug.)~%"))
 740         (t
 741          (format s "~&restarts:~%")
 742          (let ((count 0)
 743                (names-used '(nil))
 744                (max-name-len 0))
 745            (dolist (restart restarts)
 746              (let ((name (restart-name restart)))
 747                (when name
 748                  (let ((len (length (princ-to-string name))))
 749                    (when (> len max-name-len)
 750                      (setf max-name-len len))))))
 751            (unless (zerop max-name-len)
 752              (incf max-name-len 3))
 753            (dolist (restart restarts)
 754              (let ((name (restart-name restart)))
 755                (cond ((member name names-used)
 756                       (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
 757                      (t
 758                       (format s "~& ~2D: [~VA] ~A~%"
 759                               count (- max-name-len 3) name restart)
 760                       (push name names-used))))
 761              (incf count))))))
 762
 763 ;;; This calls DEBUG-LOOP, performing some simple initializations
 764 ;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
 765 ;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
 766 ;;; to get into a debug prompt as quickly as possible with as little
 767 ;;; risk as possible for stepping on whatever is causing recursive
 768 ;;; errors.
 769 (defun internal-debug ()
 770   (let ((*in-the-debugger* t)
 771         (*read-suppress* nil))
 772     (unless (typep *debug-condition* 'step-condition)
 773       (clear-input *debug-io*))
 774     #!-mp (debug-loop)
 775     #!+mp (sb!mp:without-scheduling (debug-loop))))
 776 \f
 777 ;;;; DEBUG-LOOP
 778
 779 ;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
 780 ;;; was motivated by desire to play nicely with ILISP.
 781 (defvar *flush-debug-errors* nil
 782   #!+sb-doc
 783   "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
 784    executing in the debugger.")
 785
 786 (defun debug-loop ()
 787   (let* ((*debug-command-level* (1+ *debug-command-level*))
 788          (*real-stack-top* (sb!di:top-frame))
 789          (*stack-top* (or *stack-top-hint* *real-stack-top*))
 790          (*stack-top-hint* nil)
 791          (*current-frame* *stack-top*))
 792     (handler-bind ((sb!di:debug-condition
 793                     (lambda (condition)
 794                       (princ condition *debug-io*)
 795                       (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
 796                       (throw 'debug-loop-catcher nil))))
 797       (fresh-line)
 798       (print-frame-call *current-frame* :verbosity 2)
 799       (loop
 800         (catch 'debug-loop-catcher
 801           (handler-bind ((error (lambda (condition)
 802                                   (when *flush-debug-errors*
 803                                     (clear-input *debug-io*)
 804                                     (princ condition)
 805                                     ;; FIXME: Doing input on *DEBUG-IO*
 806                                     ;; and output on T seems broken.
 807                                     (format t
 808                                             "~&error flushed (because ~
 809                                              ~S is set)"
 810                                             '*flush-debug-errors*)
 811                                     (/show0 "throwing DEBUG-LOOP-CATCHER")
 812                                     (throw 'debug-loop-catcher nil)))))
 813             ;; We have to bind LEVEL for the restart function created by
 814             ;; WITH-SIMPLE-RESTART.
 815             (let ((level *debug-command-level*)
 816                   (restart-commands (make-restart-commands)))
 817               (with-simple-restart (abort
 818                                    "Reduce debugger level (to debug level ~W)."
 819                                     level)
 820                 (debug-prompt *debug-io*)
 821                 (force-output *debug-io*)
 822                 (let ((input (sb!int:get-stream-command *debug-io*)))
 823                   (cond (input
 824                          (let ((cmd-fun (debug-command-p
 825                                          (sb!int:stream-command-name input)
 826                                          restart-commands)))
 827                            (cond
 828                             ((not cmd-fun)
 829                              (error "unknown stream-command: ~S" input))
 830                             ((consp cmd-fun)
 831                              (error "ambiguous debugger command: ~S" cmd-fun))
 832                             (t
 833                              (apply cmd-fun
 834                                     (sb!int:stream-command-args input))))))
 835                         (t
 836                          (let* ((exp (read *debug-io*))
 837                                 (cmd-fun (debug-command-p exp
 838                                                           restart-commands)))
 839                            (cond ((not cmd-fun)
 840                                   (debug-eval-print exp))
 841                                  ((consp cmd-fun)
 842                                   (format t
 843                                           "~&Your command, ~S, is ambiguous:~%"
 844                                           exp)
 845                                   (dolist (ele cmd-fun)
 846                                     (format t "   ~A~%" ele)))
 847                                  (t
 848                                   (funcall cmd-fun)))))))))))))))
 849
 850 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
 851 (defun debug-eval-print (expr)
 852   (/noshow "entering DEBUG-EVAL-PRINT" expr)
 853   (/noshow (fboundp 'compile))
 854   (setq +++ ++ ++ + + - - expr)
 855   (let* ((values (multiple-value-list (eval -)))
 856          (*standard-output* *debug-io*))
 857     (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
 858     (fresh-line)
 859     (if values (prin1 (car values)))
 860     (dolist (x (cdr values))
 861       (fresh-line)
 862       (prin1 x))
 863     (setq /// // // / / values)
 864     (setq *** ** ** * * (car values))
 865     ;; Make sure that nobody passes back an unbound marker.
 866     (unless (boundp '*)
 867       (setq * nil)
 868       (fresh-line)
 869       ;; FIXME: The way INTERACTIVE-EVAL does this seems better.
 870       (princ "Setting * to NIL (was unbound marker)."))))
 871 \f
 872 ;;;; debug loop functions
 873
 874 ;;; These commands are functions, not really commands, so that users
 875 ;;; can get their hands on the values returned.
 876
 877 (eval-when (:execute :compile-toplevel)
 878
 879 (sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
 880   `(let* ((temp (etypecase name
 881                   (symbol (sb!di:debug-fun-symbol-vars
 882                            (sb!di:frame-debug-fun *current-frame*)
 883                            name))
 884                   (simple-string (sb!di:ambiguous-debug-vars
 885                                   (sb!di:frame-debug-fun *current-frame*)
 886                                   name))))
 887           (location (sb!di:frame-code-location *current-frame*))
 888           ;; Let's only deal with valid variables.
 889           (vars (remove-if-not (lambda (v)
 890                                  (eq (sb!di:debug-var-validity v location)
 891                                      :valid))
 892                                temp)))
 893      (declare (list vars))
 894      (cond ((null vars)
 895             (error "No known valid variables match ~S." name))
 896            ((= (length vars) 1)
 897             ,(ecase ref-or-set
 898                (:ref
 899                 '(sb!di:debug-var-value (car vars) *current-frame*))
 900                (:set
 901                 `(setf (sb!di:debug-var-value (car vars) *current-frame*)
 902                        ,value-var))))
 903            (t
 904             ;; Since we have more than one, first see whether we have
 905             ;; any variables that exactly match the specification.
 906             (let* ((name (etypecase name
 907                            (symbol (symbol-name name))
 908                            (simple-string name)))
 909                    ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
 910                    ;; instead.
 911                    (exact (remove-if-not (lambda (v)
 912                                            (string= (sb!di:debug-var-symbol-name v)
 913                                                     name))
 914                                          vars))
 915                    (vars (or exact vars)))
 916               (declare (simple-string name)
 917                        (list exact vars))
 918               (cond
 919                ;; Check now for only having one variable.
 920                ((= (length vars) 1)
 921                 ,(ecase ref-or-set
 922                    (:ref
 923                     '(sb!di:debug-var-value (car vars) *current-frame*))
 924                    (:set
 925                     `(setf (sb!di:debug-var-value (car vars) *current-frame*)
 926                            ,value-var))))
 927                ;; If there weren't any exact matches, flame about
 928                ;; ambiguity unless all the variables have the same
 929                ;; name.
 930                ((and (not exact)
 931                      (find-if-not
 932                       (lambda (v)
 933                         (string= (sb!di:debug-var-symbol-name v)
 934                                  (sb!di:debug-var-symbol-name (car vars))))
 935                       (cdr vars)))
 936                 (error "specification ambiguous:~%~{   ~A~%~}"
 937                        (mapcar #'sb!di:debug-var-symbol-name
 938                                (delete-duplicates
 939                                 vars :test #'string=
 940                                 :key #'sb!di:debug-var-symbol-name))))
 941                ;; All names are the same, so see whether the user
 942                ;; ID'ed one of them.
 943                (id-supplied
 944                 (let ((v (find id vars :key #'sb!di:debug-var-id)))
 945                   (unless v
 946                     (error
 947                      "invalid variable ID, ~W: should have been one of ~S"
 948                      id
 949                      (mapcar #'sb!di:debug-var-id vars)))
 950                   ,(ecase ref-or-set
 951                      (:ref
 952                       '(sb!di:debug-var-value v *current-frame*))
 953                      (:set
 954                       `(setf (sb!di:debug-var-value v *current-frame*)
 955                              ,value-var)))))
 956                (t
 957                 (error "Specify variable ID to disambiguate ~S. Use one of ~S."
 958                        name
 959                        (mapcar #'sb!di:debug-var-id vars)))))))))
 960
 961 ) ; EVAL-WHEN
 962
 963 ;;; FIXME: This doesn't work. It would be real nice we could make it
 964 ;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
 965 (defun var (name &optional (id 0 id-supplied))
 966   #!+sb-doc
 967   "Return a variable's value if possible. NAME is a simple-string or symbol.
 968    If it is a simple-string, it is an initial substring of the variable's name.
 969    If name is a symbol, it has the same name and package as the variable whose
 970    value this function returns. If the symbol is uninterned, then the variable
 971    has the same name as the symbol, but it has no package.
 972
 973    If name is the initial substring of variables with different names, then
 974    this return no values after displaying the ambiguous names. If name
 975    determines multiple variables with the same name, then you must use the
 976    optional id argument to specify which one you want. If you left id
 977    unspecified, then this returns no values after displaying the distinguishing
 978    id values.
 979
 980    The result of this function is limited to the availability of variable
 981    information. This is SETF'able."
 982   (define-var-operation :ref))
 983 (defun (setf var) (value name &optional (id 0 id-supplied))
 984   (define-var-operation :set value))
 985
 986 ;;; This returns the COUNT'th arg as the user sees it from args, the
 987 ;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
 988 ;;; potential DEBUG-VAR from the lambda-list, then the second value is
 989 ;;; T. If this returns a keyword symbol or a value from a rest arg,
 990 ;;; then the second value is NIL.
 991 (declaim (ftype (function (index list)) nth-arg))
 992 (defun nth-arg (count args)
 993   (let ((n count))
 994     (dolist (ele args (error "The argument specification ~S is out of range."
 995                              n))
 996       (lambda-list-element-dispatch ele
 997         :required ((if (zerop n) (return (values ele t))))
 998         :optional ((if (zerop n) (return (values (second ele) t))))
 999         :keyword ((cond ((zerop n)
1000                          (return (values (second ele) nil)))
1001                         ((zerop (decf n))
1002                          (return (values (third ele) t)))))
1003         :deleted ((if (zerop n) (return (values ele t))))
1004         :rest ((let ((var (second ele)))
1005                  (lambda-var-dispatch var (sb!di:frame-code-location
1006                                            *current-frame*)
1007                    (error "unused &REST argument before n'th
1008 argument")
1009                    (dolist (value
1010                             (sb!di:debug-var-value var *current-frame*)
1011                             (error
1012                              "The argument specification ~S is out of range."
1013                              n))
1014                      (if (zerop n)
1015                          (return-from nth-arg (values value nil))
1016                          (decf n)))
1017                    (error "invalid &REST argument before n'th argument")))))
1018       (decf n))))
1019
1020 (defun arg (n)
1021   #!+sb-doc
1022   "Return the N'th argument's value if possible. Argument zero is the first
1023    argument in a frame's default printed representation. Count keyword/value
1024    pairs as separate arguments."
1025   (multiple-value-bind (var lambda-var-p)
1026       (nth-arg n (handler-case (sb!di:debug-fun-lambda-list
1027                                 (sb!di:frame-debug-fun *current-frame*))
1028                    (sb!di:lambda-list-unavailable ()
1029                      (error "No argument values are available."))))
1030     (if lambda-var-p
1031         (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
1032           (error "Unused arguments have no values.")
1033           (sb!di:debug-var-value var *current-frame*)
1034           (error "invalid argument value"))
1035         var)))
1036 \f
1037 ;;;; machinery for definition of debug loop commands
1038
1039 (defvar *debug-commands* nil)
1040
1041 ;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
1042 ;;; permitted.
1043 (defmacro !def-debug-command (name args &rest body)
1044   (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
1045     `(progn
1046        (setf *debug-commands*
1047              (remove ,name *debug-commands* :key #'car :test #'string=))
1048        (defun ,fun-name ,args
1049          (unless *in-the-debugger*
1050            (error "invoking debugger command while outside the debugger"))
1051          ,@body)
1052        (push (cons ,name #',fun-name) *debug-commands*)
1053        ',fun-name)))
1054
1055 (defun !def-debug-command-alias (new-name existing-name)
1056   (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
1057     (unless pair (error "unknown debug command name: ~S" existing-name))
1058     (push (cons new-name (cdr pair)) *debug-commands*))
1059   new-name)
1060
1061 ;;; This takes a symbol and uses its name to find a debugger command,
1062 ;;; using initial substring matching. It returns the command function
1063 ;;; if form identifies only one command, but if form is ambiguous,
1064 ;;; this returns a list of the command names. If there are no matches,
1065 ;;; this returns nil. Whenever the loop that looks for a set of
1066 ;;; possibilities encounters an exact name match, we return that
1067 ;;; command function immediately.
1068 (defun debug-command-p (form &optional other-commands)
1069   (if (or (symbolp form) (integerp form))
1070       (let* ((name
1071               (if (symbolp form)
1072                   (symbol-name form)
1073                   (format nil "~W" form)))
1074              (len (length name))
1075              (res nil))
1076         (declare (simple-string name)
1077                  (fixnum len)
1078                  (list res))
1079
1080         ;; Find matching commands, punting if exact match.
1081         (flet ((match-command (ele)
1082                  (let* ((str (car ele))
1083                         (str-len (length str)))
1084                    (declare (simple-string str)
1085                             (fixnum str-len))
1086                    (cond ((< str-len len))
1087                          ((= str-len len)
1088                           (when (string= name str :end1 len :end2 len)
1089                             (return-from debug-command-p (cdr ele))))
1090                          ((string= name str :end1 len :end2 len)
1091                           (push ele res))))))
1092           (mapc #'match-command *debug-commands*)
1093           (mapc #'match-command other-commands))
1094
1095         ;; Return the right value.
1096         (cond ((not res) nil)
1097               ((= (length res) 1)
1098                (cdar res))
1099               (t ; Just return the names.
1100                (do ((cmds res (cdr cmds)))
1101                    ((not cmds) res)
1102                  (setf (car cmds) (caar cmds))))))))
1103
1104 ;;; Return a list of debug commands (in the same format as
1105 ;;; *DEBUG-COMMANDS*) that invoke each active restart.
1106 ;;;
1107 ;;; Two commands are made for each restart: one for the number, and
1108 ;;; one for the restart name (unless it's been shadowed by an earlier
1109 ;;; restart of the same name, or it is NIL).
1110 (defun make-restart-commands (&optional (restarts *debug-restarts*))
1111   (let ((commands)
1112         (num 0))                        ; better be the same as show-restarts!
1113     (dolist (restart restarts)
1114       (let ((name (string (restart-name restart))))
1115         (let ((restart-fun
1116                 (lambda ()
1117                   (/show0 "in restart-command closure, about to i-r-i")
1118                   (invoke-restart-interactively restart))))
1119           (push (cons (prin1-to-string num) restart-fun) commands)
1120           (unless (or (null (restart-name restart))
1121                       (find name commands :key #'car :test #'string=))
1122             (push (cons name restart-fun) commands))))
1123     (incf num))
1124   commands))
1125 \f
1126 ;;;; frame-changing commands
1127
1128 (!def-debug-command "UP" ()
1129   (let ((next (sb!di:frame-up *current-frame*)))
1130     (cond (next
1131            (setf *current-frame* next)
1132            (print-frame-call next))
1133           (t
1134            (format t "~&Top of stack.")))))
1135
1136 (!def-debug-command "DOWN" ()
1137   (let ((next (sb!di:frame-down *current-frame*)))
1138     (cond (next
1139            (setf *current-frame* next)
1140            (print-frame-call next))
1141           (t
1142            (format t "~&Bottom of stack.")))))
1143
1144 (!def-debug-command-alias "D" "DOWN")
1145
1146 ;;; CMU CL had this command, but SBCL doesn't, since it's redundant
1147 ;;; with "FRAME 0", and it interferes with abbreviations for the
1148 ;;; TOPLEVEL restart.
1149 ;;;(!def-debug-command "TOP" ()
1150 ;;;  (do ((prev *current-frame* lead)
1151 ;;;       (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
1152 ;;;      ((null lead)
1153 ;;;       (setf *current-frame* prev)
1154 ;;;       (print-frame-call prev))))
1155
1156 (!def-debug-command "BOTTOM" ()
1157   (do ((prev *current-frame* lead)
1158        (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
1159       ((null lead)
1160        (setf *current-frame* prev)
1161        (print-frame-call prev))))
1162
1163 (!def-debug-command-alias "B" "BOTTOM")
1164
1165 (!def-debug-command "FRAME" (&optional
1166                              (n (read-prompting-maybe "frame number: ")))
1167   (setf *current-frame*
1168         (multiple-value-bind (next-frame-fun limit-string)
1169             (if (< n (sb!di:frame-number *current-frame*))
1170                 (values #'sb!di:frame-up "top")
1171               (values #'sb!di:frame-down "bottom"))
1172           (do ((frame *current-frame*))
1173               ((= n (sb!di:frame-number frame))
1174                frame)
1175             (let ((next-frame (funcall next-frame-fun frame)))
1176               (cond (next-frame
1177                      (setf frame next-frame))
1178                     (t
1179                      (format t
1180                              "The ~A of the stack was encountered.~%"
1181                              limit-string)
1182                      (return frame)))))))
1183   (print-frame-call *current-frame*))
1184
1185 (!def-debug-command-alias "F" "FRAME")
1186 \f
1187 ;;;; commands for entering and leaving the debugger
1188
1189 ;;; CMU CL supported this QUIT debug command, but SBCL provides this
1190 ;;; functionality with a restart instead. (The QUIT debug command was
1191 ;;; removed because it's confusing to have "quit" mean two different
1192 ;;; things in the system, "restart the top level REPL" in the debugger
1193 ;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.)
1194 ;;;
1195 ;;;(!def-debug-command "QUIT" ()
1196 ;;;  (throw 'sb!impl::toplevel-catcher nil))
1197
1198 ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in
1199 ;;; SBCL you just type the CONTINUE restart name instead (or "RESTART
1200 ;;; CONTINUE", that's OK too).
1201
1202 ;;;(!def-debug-command "GO" ()
1203 ;;;  (continue *debug-condition*)
1204 ;;;  (error "There is no restart named CONTINUE."))
1205
1206 (!def-debug-command "RESTART" ()
1207   (/show0 "doing RESTART debug-command")
1208   (let ((num (read-if-available :prompt)))
1209     (when (eq num :prompt)
1210       (show-restarts *debug-restarts* *debug-io*)
1211       (write-string "restart: ")
1212       (force-output)
1213       (setf num (read *debug-io*)))
1214     (let ((restart (typecase num
1215                      (unsigned-byte
1216                       (nth num *debug-restarts*))
1217                      (symbol
1218                       (find num *debug-restarts* :key #'restart-name
1219                             :test (lambda (sym1 sym2)
1220                                     (string= (symbol-name sym1)
1221                                              (symbol-name sym2)))))
1222                      (t
1223                       (format t "~S is invalid as a restart name.~%" num)
1224                       (return-from restart-debug-command nil)))))
1225       (/show0 "got RESTART")
1226       (if restart
1227           (invoke-restart-interactively restart)
1228           ;; FIXME: Even if this isn't handled by WARN, it probably
1229           ;; shouldn't go to *STANDARD-OUTPUT*, but *ERROR-OUTPUT* or
1230           ;; *QUERY-IO* or something. Look through this file to
1231           ;; straighten out stream usage.
1232           (princ "There is no such restart.")))))
1233 \f
1234 ;;;; information commands
1235
1236 (!def-debug-command "HELP" ()
1237   ;; CMU CL had a little toy pager here, but "if you aren't running
1238   ;; ILISP (or a smart windowing system, or something) you deserve to
1239   ;; lose", so we've dropped it in SBCL. However, in case some
1240   ;; desperate holdout is running this on a dumb terminal somewhere,
1241   ;; we tell him where to find the message stored as a string.
1242   (format *debug-io*
1243           "~&~A~2%(The HELP string is stored in ~S.)~%"
1244           *debug-help-string*
1245           '*debug-help-string*))
1246
1247 (!def-debug-command-alias "?" "HELP")
1248
1249 (!def-debug-command "ERROR" ()
1250   (format *debug-io* "~A~%" *debug-condition*)
1251   (show-restarts *debug-restarts* *debug-io*))
1252
1253 (!def-debug-command "BACKTRACE" ()
1254   (backtrace (read-if-available most-positive-fixnum)))
1255
1256 (!def-debug-command "PRINT" ()
1257   (print-frame-call *current-frame*))
1258
1259 (!def-debug-command-alias "P" "PRINT")
1260
1261 (!def-debug-command "LIST-LOCALS" ()
1262   (let ((d-fun (sb!di:frame-debug-fun *current-frame*)))
1263     (if (sb!di:debug-var-info-available d-fun)
1264         (let ((*standard-output* *debug-io*)
1265               (location (sb!di:frame-code-location *current-frame*))
1266               (prefix (read-if-available nil))
1267               (any-p nil)
1268               (any-valid-p nil))
1269           (dolist (v (sb!di:ambiguous-debug-vars
1270                         d-fun
1271                         (if prefix (string prefix) "")))
1272             (setf any-p t)
1273             (when (eq (sb!di:debug-var-validity v location) :valid)
1274               (setf any-valid-p t)
1275               (format t "~S~:[#~W~;~*~]  =  ~S~%"
1276                       (sb!di:debug-var-symbol v)
1277                       (zerop (sb!di:debug-var-id v))
1278                       (sb!di:debug-var-id v)
1279                       (sb!di:debug-var-value v *current-frame*))))
1280
1281           (cond
1282            ((not any-p)
1283             (format t "There are no local variables ~@[starting with ~A ~]~
1284                        in the function."
1285                     prefix))
1286            ((not any-valid-p)
1287             (format t "All variables ~@[starting with ~A ~]currently ~
1288                        have invalid values."
1289                     prefix))))
1290         (write-line "There is no variable information available."))))
1291
1292 (!def-debug-command-alias "L" "LIST-LOCALS")
1293
1294 (!def-debug-command "SOURCE" ()
1295   (fresh-line)
1296   (print-code-location-source-form (sb!di:frame-code-location *current-frame*)
1297                                    (read-if-available 0)))
1298 \f
1299 ;;;; source location printing
1300
1301 ;;; We cache a stream to the last valid file debug source so that we
1302 ;;; won't have to repeatedly open the file.
1303 ;;;
1304 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
1305 ;;; in the 1990s, so the benefit is negligible, less important than the
1306 ;;; potential of extra confusion if someone changes the source during
1307 ;;; a debug session and the change doesn't show up. And removing this
1308 ;;; would simplify the system, which I like. -- WHN 19990903
1309 (defvar *cached-debug-source* nil)
1310 (declaim (type (or sb!di:debug-source null) *cached-debug-source*))
1311 (defvar *cached-source-stream* nil)
1312 (declaim (type (or stream null) *cached-source-stream*))
1313
1314 ;;; To suppress the read-time evaluation #. macro during source read,
1315 ;;; *READTABLE* is modified. *READTABLE* is cached to avoid
1316 ;;; copying it each time, and invalidated when the
1317 ;;; *CACHED-DEBUG-SOURCE* has changed.
1318 (defvar *cached-readtable* nil)
1319 (declaim (type (or readtable null) *cached-readtable*))
1320
1321 (pushnew (lambda ()
1322            (setq *cached-debug-source* nil *cached-source-stream* nil
1323                  *cached-readtable* nil))
1324          *before-save-initializations*)
1325
1326 ;;; We also cache the last toplevel form that we printed a source for
1327 ;;; so that we don't have to do repeated reads and calls to
1328 ;;; FORM-NUMBER-TRANSLATIONS.
1329 (defvar *cached-toplevel-form-offset* nil)
1330 (declaim (type (or index null) *cached-toplevel-form-offset*))
1331 (defvar *cached-toplevel-form*)
1332 (defvar *cached-form-number-translations*)
1333
1334 ;;; Given a code location, return the associated form-number
1335 ;;; translations and the actual top level form. We check our cache ---
1336 ;;; if there is a miss, we dispatch on the kind of the debug source.
1337 (defun get-toplevel-form (location)
1338   (let ((d-source (sb!di:code-location-debug-source location)))
1339     (if (and (eq d-source *cached-debug-source*)
1340              (eql (sb!di:code-location-toplevel-form-offset location)
1341                   *cached-toplevel-form-offset*))
1342         (values *cached-form-number-translations* *cached-toplevel-form*)
1343         (let* ((offset (sb!di:code-location-toplevel-form-offset location))
1344                (res
1345                 (ecase (sb!di:debug-source-from d-source)
1346                   (:file (get-file-toplevel-form location))
1347                   (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
1348           (setq *cached-toplevel-form-offset* offset)
1349           (values (setq *cached-form-number-translations*
1350                         (sb!di:form-number-translations res offset))
1351                   (setq *cached-toplevel-form* res))))))
1352
1353 ;;; Locate the source file (if it still exists) and grab the top level
1354 ;;; form. If the file is modified, we use the top level form offset
1355 ;;; instead of the recorded character offset.
1356 (defun get-file-toplevel-form (location)
1357   (let* ((d-source (sb!di:code-location-debug-source location))
1358          (tlf-offset (sb!di:code-location-toplevel-form-offset location))
1359          (local-tlf-offset (- tlf-offset
1360                               (sb!di:debug-source-root-number d-source)))
1361          (char-offset
1362           (aref (or (sb!di:debug-source-start-positions d-source)
1363                     (error "no start positions map"))
1364                 local-tlf-offset))
1365          (name (sb!di:debug-source-name d-source)))
1366     (unless (eq d-source *cached-debug-source*)
1367       (unless (and *cached-source-stream*
1368                    (equal (pathname *cached-source-stream*)
1369                           (pathname name)))
1370         (setq *cached-readtable* nil)
1371         (when *cached-source-stream* (close *cached-source-stream*))
1372         (setq *cached-source-stream* (open name :if-does-not-exist nil))
1373         (unless *cached-source-stream*
1374           (error "The source file no longer exists:~%  ~A" (namestring name)))
1375         (format t "~%; file: ~A~%" (namestring name)))
1376
1377         (setq *cached-debug-source*
1378               (if (= (sb!di:debug-source-created d-source)
1379                      (file-write-date name))
1380                   d-source nil)))
1381
1382     (cond
1383      ((eq *cached-debug-source* d-source)
1384       (file-position *cached-source-stream* char-offset))
1385      (t
1386       (format t "~%; File has been modified since compilation:~%;   ~A~@
1387                  ; Using form offset instead of character position.~%"
1388               (namestring name))
1389       (file-position *cached-source-stream* 0)
1390       (let ((*read-suppress* t))
1391         (dotimes (i local-tlf-offset)
1392           (read *cached-source-stream*)))))
1393     (unless *cached-readtable*
1394       (setq *cached-readtable* (copy-readtable))
1395       (set-dispatch-macro-character
1396        #\# #\.
1397        (lambda (stream sub-char &rest rest)
1398          (declare (ignore rest sub-char))
1399          (let ((token (read stream t nil t)))
1400            (format nil "#.~S" token)))
1401        *cached-readtable*))
1402     (let ((*readtable* *cached-readtable*))
1403       (read *cached-source-stream*))))
1404
1405 (defun print-code-location-source-form (location context)
1406   (let* ((location (maybe-block-start-location location))
1407          (form-num (sb!di:code-location-form-number location)))
1408     (multiple-value-bind (translations form) (get-toplevel-form location)
1409       (unless (< form-num (length translations))
1410         (error "The source path no longer exists."))
1411       (prin1 (sb!di:source-path-context form
1412                                         (svref translations form-num)
1413                                         context)))))
1414 \f
1415 ;;; breakpoint and step commands
1416
1417 ;;; Step to the next code-location.
1418 (!def-debug-command "STEP" ()
1419   (setf *number-of-steps* (read-if-available 1))
1420   (set-step-breakpoint *current-frame*)
1421   (continue *debug-condition*)
1422   (error "couldn't continue"))
1423
1424 ;;; List possible breakpoint locations, which ones are active, and
1425 ;;; where the CONTINUE restart will transfer control. Set
1426 ;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
1427 ;;; used by sbreakpoint.
1428 (!def-debug-command "LIST-LOCATIONS" ()
1429   (let ((df (read-if-available *default-breakpoint-debug-fun*)))
1430     (cond ((consp df)
1431            (setf df (sb!di:fun-debug-fun (eval df)))
1432            (setf *default-breakpoint-debug-fun* df))
1433           ((or (eq ':c df)
1434                (not *default-breakpoint-debug-fun*))
1435            (setf df (sb!di:frame-debug-fun *current-frame*))
1436            (setf *default-breakpoint-debug-fun* df)))
1437     (setf *possible-breakpoints* (possible-breakpoints df)))
1438   (let ((continue-at (sb!di:frame-code-location *current-frame*)))
1439     (let ((active (location-in-list *default-breakpoint-debug-fun*
1440                                     *breakpoints* :fun-start))
1441           (here (sb!di:code-location=
1442                  (sb!di:debug-fun-start-location
1443                   *default-breakpoint-debug-fun*) continue-at)))
1444       (when (or active here)
1445         (format t "::FUN-START ")
1446         (when active (format t " *Active*"))
1447         (when here (format t " *Continue here*"))))
1448
1449     (let ((prev-location nil)
1450           (prev-num 0)
1451           (this-num 0))
1452       (flet ((flush ()
1453                (when prev-location
1454                  (let ((this-num (1- this-num)))
1455                    (if (= prev-num this-num)
1456                        (format t "~&~W: " prev-num)
1457                        (format t "~&~W-~W: " prev-num this-num)))
1458                  (print-code-location-source-form prev-location 0)
1459                  (when *print-location-kind*
1460                    (format t "~S " (sb!di:code-location-kind prev-location)))
1461                  (when (location-in-list prev-location *breakpoints*)
1462                    (format t " *Active*"))
1463                  (when (sb!di:code-location= prev-location continue-at)
1464                    (format t " *Continue here*")))))
1465
1466         (dolist (code-location *possible-breakpoints*)
1467           (when (or *print-location-kind*
1468                     (location-in-list code-location *breakpoints*)
1469                     (sb!di:code-location= code-location continue-at)
1470                     (not prev-location)
1471                     (not (eq (sb!di:code-location-debug-source code-location)
1472                              (sb!di:code-location-debug-source prev-location)))
1473                     (not (eq (sb!di:code-location-toplevel-form-offset
1474                               code-location)
1475                              (sb!di:code-location-toplevel-form-offset
1476                               prev-location)))
1477                     (not (eq (sb!di:code-location-form-number code-location)
1478                              (sb!di:code-location-form-number prev-location))))
1479             (flush)
1480             (setq prev-location code-location  prev-num this-num))
1481
1482           (incf this-num))))
1483
1484     (when (location-in-list *default-breakpoint-debug-fun*
1485                             *breakpoints*
1486                             :fun-end)
1487       (format t "~&::FUN-END *Active* "))))
1488
1489 (!def-debug-command-alias "LL" "LIST-LOCATIONS")
1490
1491 ;;; Set breakpoint at the given number.
1492 (!def-debug-command "BREAKPOINT" ()
1493   (let ((index (read-prompting-maybe "location number, :START, or :END: "))
1494         (break t)
1495         (condition t)
1496         (print nil)
1497         (print-functions nil)
1498         (function nil)
1499         (bp)
1500         (place *default-breakpoint-debug-fun*))
1501     (flet ((get-command-line ()
1502              (let ((command-line nil)
1503                    (unique '(nil)))
1504                (loop
1505                  (let ((next-input (read-if-available unique)))
1506                    (when (eq next-input unique) (return))
1507                    (push next-input command-line)))
1508                (nreverse command-line)))
1509            (set-vars-from-command-line (command-line)
1510              (do ((arg (pop command-line) (pop command-line)))
1511                  ((not arg))
1512                (ecase arg
1513                  (:condition (setf condition (pop command-line)))
1514                  (:print (push (pop command-line) print))
1515                  (:break (setf break (pop command-line)))
1516                  (:function
1517                   (setf function (eval (pop command-line)))
1518                   (setf *default-breakpoint-debug-fun*
1519                         (sb!di:fun-debug-fun function))
1520                   (setf place *default-breakpoint-debug-fun*)
1521                   (setf *possible-breakpoints*
1522                         (possible-breakpoints
1523                          *default-breakpoint-debug-fun*))))))
1524            (setup-fun-start ()
1525              (let ((code-loc (sb!di:debug-fun-start-location place)))
1526                (setf bp (sb!di:make-breakpoint #'main-hook-fun
1527                                                place
1528                                                :kind :fun-start))
1529                (setf break (sb!di:preprocess-for-eval break code-loc))
1530                (setf condition (sb!di:preprocess-for-eval condition code-loc))
1531                (dolist (form print)
1532                  (push (cons (sb!di:preprocess-for-eval form code-loc) form)
1533                        print-functions))))
1534            (setup-fun-end ()
1535              (setf bp
1536                    (sb!di:make-breakpoint #'main-hook-fun
1537                                           place
1538                                           :kind :fun-end))
1539              (setf break
1540                    ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
1541                    ;; forms should be converted to shiny new (LAMBDA ..) forms.
1542                    ;; (Search the sources for "coerce.*\(lambda".)
1543                    (coerce `(lambda (dummy)
1544                               (declare (ignore dummy)) ,break)
1545                            'function))
1546              (setf condition (coerce `(lambda (dummy)
1547                                         (declare (ignore dummy)) ,condition)
1548                                      'function))
1549              (dolist (form print)
1550                (push (cons
1551                       (coerce `(lambda (dummy)
1552                                  (declare (ignore dummy)) ,form) 'function)
1553                       form)
1554                      print-functions)))
1555            (setup-code-location ()
1556              (setf place (nth index *possible-breakpoints*))
1557              (setf bp (sb!di:make-breakpoint #'main-hook-fun place
1558                                              :kind :code-location))
1559              (dolist (form print)
1560                (push (cons
1561                       (sb!di:preprocess-for-eval form place)
1562                       form)
1563                      print-functions))
1564              (setf break (sb!di:preprocess-for-eval break place))
1565              (setf condition (sb!di:preprocess-for-eval condition place))))
1566       (set-vars-from-command-line (get-command-line))
1567       (cond
1568        ((or (eq index :start) (eq index :s))
1569         (setup-fun-start))
1570        ((or (eq index :end) (eq index :e))
1571         (setup-fun-end))
1572        (t
1573         (setup-code-location)))
1574       (sb!di:activate-breakpoint bp)
1575       (let* ((new-bp-info (create-breakpoint-info place bp index
1576                                                   :break break
1577                                                   :print print-functions
1578                                                   :condition condition))
1579              (old-bp-info (location-in-list new-bp-info *breakpoints*)))
1580         (when old-bp-info
1581           (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
1582                                         old-bp-info))
1583           (setf *breakpoints* (remove old-bp-info *breakpoints*))
1584           (format t "previous breakpoint removed~%"))
1585         (push new-bp-info *breakpoints*))
1586       (print-breakpoint-info (first *breakpoints*))
1587       (format t "~&added"))))
1588
1589 (!def-debug-command-alias "BP" "BREAKPOINT")
1590
1591 ;;; List all breakpoints which are set.
1592 (!def-debug-command "LIST-BREAKPOINTS" ()
1593   (setf *breakpoints*
1594         (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
1595   (dolist (info *breakpoints*)
1596     (print-breakpoint-info info)))
1597
1598 (!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
1599 (!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
1600
1601 ;;; Remove breakpoint N, or remove all breakpoints if no N given.
1602 (!def-debug-command "DELETE-BREAKPOINT" ()
1603   (let* ((index (read-if-available nil))
1604          (bp-info
1605           (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
1606     (cond (bp-info
1607            (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
1608            (setf *breakpoints* (remove bp-info *breakpoints*))
1609            (format t "breakpoint ~S removed~%" index))
1610           (index (format t "The breakpoint doesn't exist."))
1611           (t
1612            (dolist (ele *breakpoints*)
1613              (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele)))
1614            (setf *breakpoints* nil)
1615            (format t "all breakpoints deleted~%")))))
1616
1617 (!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
1618 \f
1619 ;;; miscellaneous commands
1620
1621 (!def-debug-command "DESCRIBE" ()
1622   (let* ((curloc (sb!di:frame-code-location *current-frame*))
1623          (debug-fun (sb!di:code-location-debug-fun curloc))
1624          (function (sb!di:debug-fun-fun debug-fun)))
1625     (if function
1626         (describe function)
1627         (format t "can't figure out the function for this frame"))))
1628
1629 (!def-debug-command "SLURP" ()
1630   (loop while (read-char-no-hang *standard-input*)))
1631 \f
1632 ;;;; debug loop command utilities
1633
1634 (defun read-prompting-maybe (prompt)
1635   (unless (sb!int:listen-skip-whitespace *debug-io*)
1636     (princ prompt)
1637     (force-output))
1638   (read *debug-io*))
1639
1640 (defun read-if-available (default)
1641   (if (sb!int:listen-skip-whitespace *debug-io*)
1642       (read *debug-io*)
1643       default))