src/interface/debug.lisp

   1 ;;;; -*- Mode: Lisp ; Package: Debug -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written as part of the CMU Common Lisp project at
   5 ;;; Carnegie Mellon University, and has been placed in the public domain.
   6 ;;;
   7 (ext:file-comment
   8   "$Header: src/interface/debug.lisp $")
   9 ;;;
  10 ;;; **********************************************************************
  11 ;;;
  12 ;;; Written by Michael Garland
  13 ;;;
  14 ;;; This file implements the graphical interface to the debugger.
  15 ;;;
  16
  17 (in-package "DEBUG")
  18 (use-package '("TOOLKIT" "INTERFACE"))
  19
  20 ;;; We need to record three things globally:
  21 ;;;    - The structure decribing the current debugger display
  22 ;;;    - The frame displays which are currently active (ie. visible)
  23 ;;;    - The husks of old debugger displays for reuse
  24 ;;;
  25 (defvar *current-debug-display* nil)
  26 (defvar *debug-active-frames* nil)
  27 (defvar *old-display-frames* nil)
  28
  29 \f
  30
  31 ;;;; Structures used by the graphical debugger
  32
  33 (defstruct (debug-display
  34             (:conc-name dd-info-)
  35             (:print-function print-debug-display)
  36             (:constructor make-debug-display
  37                           (debug-pane errmsg restarts backtrace)))
  38   (debug-pane nil :type (or null widget))
  39   (errmsg nil :type (or null widget))
  40   (restarts nil :type (or null widget))
  41   (backtrace nil :type (or null widget))
  42   (level 0 :type fixnum)
  43   (connection nil :type (or null xt::motif-connection)))
  44
  45 (defun print-debug-display (info stream d)
  46   (declare (ignore d))
  47   (format stream "#<Debugger Display Info level ~d" (dd-info-level info)))
  48
  49 \f
  50
  51 ;;;; Callback functions used by debugger
  52
  53 (defun quit-debugger-callback (widget call-data)
  54   (declare (ignore widget call-data))
  55   (close-motif-debugger *debug-condition*)
  56   (throw 'lisp::top-level-catcher nil))
  57
  58 (defun restart-callback (widget call-data restart)
  59   (declare (ignore widget call-data))
  60   (invoke-restart-interactively restart))
  61
  62 (defun stack-frame-callback (widget call-data frame)
  63   (declare (ignore widget call-data))
  64   (unless (assoc frame *debug-active-frames*)
  65     ;; Should wrap this in a busy cursor
  66     (debug-display-frame frame)))
  67
  68 (defun close-all-callback (widget call-data)
  69   (declare (ignore widget call-data))
  70   (dolist (info *debug-active-frames*)
  71     (destroy-widget (cdr info)))
  72   (setf *debug-active-frames* nil))
  73
  74 ;;; This is to provide a means for recording the stack backtrace.  In
  75 ;;; particular, this is important for sending bug reports.
  76 ;;;
  77 (defun dump-backtrace-callback (widget call-data)
  78   (declare (ignore widget call-data))
  79   (let ((*current-frame* (di:top-frame)))
  80     (format t "~%Stack Backtrace:~%")
  81     (backtrace)))
  82
  83 (defun frame-view-callback (widget call-data thing)
  84   (declare (ignore widget call-data))
  85   ;; Should wrap this in a busy cursor
  86   (inspect thing))
  87
  88 (defun close-frame-callback (widget call-data frame)
  89   (declare (ignore widget call-data))
  90   (setf *debug-active-frames*
  91         (delete frame *debug-active-frames*
  92                 :test #'(lambda (a b) (eql a (car b)))))
  93   (destroy-interface-pane frame))
  94
  95 (defun edit-source-callback (widget call-data frame)
  96   (declare (ignore widget call-data))
  97   (handler-case
  98       (let ((*current-frame* frame))
  99         (funcall (debug-command-p :edit-source)))
 100     (error (cond)
 101            (interface-error (safe-condition-message cond)))))
 102
 103 (defun frame-eval-callback (widget call-data frame output)
 104   (declare (ignore call-data))
 105   (let* ((input (car (get-values widget :value)))
 106          (mark (text-get-last-position output))
 107          (response
 108           (format nil "Eval>> ~a~%~a--------------------~%"
 109                   input
 110                   (handler-case
 111                       (multiple-value-bind
 112                           (out val)
 113                           (let ((*current-frame* frame))
 114                             (grab-output-as-string
 115                              (di:eval-in-frame frame (read-from-string input))))
 116                         (format nil "~a~s~%" out val))
 117                     (error (cond)
 118                            (safe-condition-message cond)))))
 119          (length (length response)))
 120     (declare (simple-string response))
 121
 122     (text-set-string widget "")
 123     (text-insert output mark response)
 124     ;; This is to make sure that things stay visible
 125     (text-set-insertion-position output (+ length mark))))
 126
 127 (defun source-verbosity-callback (widget call-data frame srcview delta)
 128   (declare (ignore widget call-data))
 129   (let* ((current (car (get-values srcview :user-data)))
 130          (new (+ current delta)))
 131     (when (minusp new)
 132       (setf new 0))
 133     (let ((source (handler-case
 134                      (grab-output-as-string
 135                       (print-code-location-source-form
 136                        (di:frame-code-location frame) new))
 137                    (di:debug-condition (cond)
 138                      (declare (ignore cond))
 139                      "Source form not available."))))
 140       (set-values srcview
 141                   :label-string source
 142                   :user-data new))))
 143
 144 \f
 145
 146 ;;; DEBUG-DISPLAY-FRAME-LOCALS -- Internal
 147 ;;;
 148 ;;; This sets up the display of the available local variables for the given
 149 ;;; stack frame.
 150 ;;;
 151 (defun debug-display-frame-locals (frame debug-fun location frame-view)
 152   (let (widgets)
 153     (if (di:debug-variable-info-available debug-fun)
 154         (let ((any-p nil)
 155               (any-valid-p nil))
 156           (di:do-debug-function-variables (v debug-fun)
 157             (unless any-p
 158               (setf any-p t)
 159               (push (create-label frame-view "localsLabel"
 160                                          :font-list *header-font*
 161                                          :label-string "Local variables:")
 162                     widgets))
 163             (when (eq (di:debug-variable-validity v location) :valid)
 164               (let ((value (di:debug-variable-value v frame))
 165                     (id (di:debug-variable-id v)))
 166                 (setf any-valid-p t)
 167                 (push
 168                  (create-value-box frame-view
 169                                    (format nil "   ~A~:[#~D~;~*~]:"
 170                                            (di:debug-variable-name v)
 171                                            (zerop id) id)
 172                                    value
 173                                    :callback 'frame-view-callback)
 174                  widgets))))
 175           (cond
 176            ((not any-p)
 177             (push
 178              (create-label frame-view "noLocals"
 179                                   :font-list *italic-font*
 180                                   :label-string
 181                                   "   No local variables in function.")
 182              widgets))
 183            ((not any-valid-p)
 184             (push
 185              (create-label frame-view "noValidLocals"
 186                                   :font-list *italic-font*
 187                                   :label-string
 188                                   "   All variables have invalid values.")
 189              widgets))))
 190
 191         (push (create-label frame-view "noVariableInfo"
 192                                    :font-list *italic-font*
 193                                    :label-string
 194                                    "   No variable information available.")
 195               widgets))
 196     (apply #'manage-children widgets)))
 197
 198 ;;; DEBUG-DISPLAY-FRAME-PROMPT -- Internal
 199 ;;;
 200 ;;; Every frame window has a Frame Eval area.  This function creates the
 201 ;;; Eval area and attaches the necessary callbacks.
 202 ;;;
 203 (defun debug-display-frame-prompt (frame frame-view)
 204   (let* ((form (create-form frame-view "promptForm"))
 205          (label (create-label form "framePrompt"
 206                                      :label-string "Frame Eval:"
 207                                      :font-list *header-font*))
 208          (entry (create-text form "frameEval"
 209                              :top-attachment :attach-widget
 210                              :top-widget label
 211                              :left-attachment :attach-form
 212                              :right-attachment :attach-form))
 213          (output (create-text form "frameOutput"
 214                               :edit-mode :multi-line-edit
 215                               :editable nil
 216                               :rows 8
 217                               :columns 40
 218                               :top-attachment :attach-widget
 219                               :top-widget entry
 220                               :bottom-attachment :attach-form
 221                               :left-attachment :attach-form
 222                               :right-attachment :attach-form)))
 223
 224     (manage-child form)
 225     (manage-children label entry output)
 226     (add-callback entry :activate-callback 'frame-eval-callback
 227                   frame output)))
 228
 229 ;;; DEBUG-DISPLAY-FRAME -- Internal
 230 ;;;
 231 ;;; Function to generate the graphical display for the given frame.  Each
 232 ;;; frame window is composed of the following parts:
 233 ;;;    - The function called
 234 ;;;    - The source form
 235 ;;;    - Local variables
 236 ;;;    - Frame Eval window
 237 ;;;
 238 (defun debug-display-frame (frame)
 239   (let* ((debug-fun (di:frame-debug-function frame))
 240          (location (di:frame-code-location frame))
 241          (name (di:debug-function-name debug-fun))
 242          (title (format nil "Stack Frame: ~A" name))
 243          (frame-shell (create-interface-pane-shell title frame))
 244          (frame-view (create-row-column frame-shell "debugFrameView"))
 245          (menu-bar (create-menu-bar frame-view "frameMenu"))
 246          (fcall (create-label frame-view "frameCall"
 247                                      :label-string
 248                                      (format nil "Frame Call: ~a"
 249                                              (grab-output-as-string
 250                                               (print-frame-call frame)))))
 251          (fbox (create-value-box frame-view "Function:"
 252                                  name
 253                                  :callback 'frame-view-callback
 254                                  :client-data
 255                                  (di:debug-function-function debug-fun)))
 256          (slabel (create-label frame-view "sourceLabel"
 257                                       :font-list *header-font*
 258                                       :label-string "Source form:"))
 259          (swindow (create-scrolled-window frame-view "frameSourceWindow"
 260                                           :scrolling-policy :automatic
 261                                           :scroll-bar-placement :bottom-right))
 262
 263          (source (handler-case
 264                      (grab-output-as-string
 265                       (print-code-location-source-form location 0))
 266                    (di:debug-condition (cond)
 267                      (declare (ignore cond))
 268                      "Source form not available.")))
 269          (srcview (create-label swindow "sourceForm"
 270                                 :alignment :alignment-beginning
 271                                 :user-data 0
 272                                 :label-string source))
 273          (cascade1
 274           (create-interface-menu menu-bar "Frame"
 275            `(("Edit Source" edit-source-callback ,frame)
 276              ("Expand Source Form" source-verbosity-callback ,frame ,srcview 1)
 277              ("Shrink Source Form" source-verbosity-callback ,frame ,srcview -1)
 278              ("Close Frame" close-frame-callback ,frame))))
 279          (cascade2 (create-cached-menu menu-bar "Debug")))
 280
 281     (manage-child frame-view)
 282     (manage-children menu-bar fcall fbox slabel swindow)
 283     (manage-child srcview)
 284     (manage-children cascade1 cascade2)
 285
 286     (debug-display-frame-locals frame debug-fun location frame-view)
 287     (debug-display-frame-prompt frame frame-view)
 288
 289     (popup-interface-pane frame-shell)
 290     (push (cons frame frame-shell) *debug-active-frames*)))
 291
 292 \f
 293
 294 ;;;; Functions to display the debugger control panel
 295
 296 ;;; DEBUG-DISPLAY-ERROR -- Internal
 297 ;;;
 298 ;;; Fills in the given widget with the error message for the given
 299 ;;; condition.
 300 ;;;
 301 (defun debug-display-error (errmsg condition)
 302   (set-values errmsg :label-string (safe-condition-message condition)))
 303
 304 ;;; DEBUG-DISPLAY-RESTARTS -- Internal
 305 ;;;
 306 ;;; Fills in a RowColumn box with buttons corresponding to the currently
 307 ;;; active restarts.
 308 ;;;
 309 (defun debug-display-restarts (restart-view)
 310   (let ((widgets (reverse (xti:widget-children restart-view)))
 311         (used-ones))
 312
 313     (dolist (r *debug-restarts*)
 314       (let* ((label (format nil "~A" r))
 315              (button (if widgets
 316                          (let ((w (pop widgets)))
 317                            (set-values w :label-string label)
 318                            (remove-all-callbacks w :activate-callback)
 319                            w)
 320                          (create-highlight-button restart-view
 321                                                   "restartButton"
 322                                                   label))))
 323
 324         (add-callback button :activate-callback 'restart-callback r)
 325         (push button used-ones)))
 326     (apply #'manage-children used-ones)
 327     (when widgets
 328       (apply #'unmanage-children widgets))))
 329
 330 ;;; DEBUG-DISPLAY-STACK -- Internal
 331 ;;;
 332 ;;; Fills in a RowColumn box with buttons corresponding to the stack frames
 333 ;;; found on the stack.
 334 ;;;
 335 (defun debug-display-stack (backtrace)
 336   (let ((widgets (reverse (xti:widget-children backtrace)))
 337         (used-ones)
 338         (frames))
 339
 340     (do ((frame *current-frame* (di:frame-down frame)))
 341         ((null frame))
 342       (push frame frames))
 343     (setf frames (nreverse frames))
 344
 345     (dolist (frame frames)
 346       (let* ((label (grab-output-as-string
 347                      (print-frame-call frame)))
 348              (button (if widgets
 349                          (let ((w (pop widgets)))
 350                            (set-values w :label-string label)
 351                            (remove-all-callbacks w :activate-callback)
 352                            w)
 353                          (create-highlight-button
 354                           backtrace "stackFrame" label))))
 355         (add-callback button :activate-callback 'stack-frame-callback frame)
 356         (push button used-ones)))
 357     (apply #'manage-children used-ones)
 358     (when widgets
 359       (apply #'unmanage-children widgets))))
 360
 361 ;;; REALLY-CREATE-DEBUGGER -- Internal
 362 ;;;
 363 ;;; This creates all the widgets used by the main debugger window.  It
 364 ;;; calls various sub-functions such as DEBUG-DISPLAY-STACK to fill in the
 365 ;;; various display sections.  It should only be called if there are no old
 366 ;;; debugger panes available for recycling.
 367 ;;;
 368 (defun really-create-debugger (condition)
 369   (let* ((debug-pane (create-interface-pane-shell "Debugger" condition))
 370          (frame (create-frame debug-pane "debugFrame"))
 371          (form (create-form frame "debugForm"))
 372          (menu-bar (create-menu-bar form "debugMenu"
 373                                     :left-attachment :attach-form
 374                                     :right-attachment :attach-form))
 375          (cascade (create-cached-menu
 376                    menu-bar "Debug"
 377                    '(("Close All Frames" close-all-callback)
 378                      ("Dump Backtrace" dump-backtrace-callback)
 379                      ("Quit Debugger" quit-debugger-callback))))
 380          (errlabel (create-label form "errorLabel"
 381                                         :top-attachment :attach-widget
 382                                         :top-widget menu-bar
 383                                         :left-attachment :attach-form
 384                                         :font-list *header-font*
 385                                         :label-string "Error Message:"))
 386          (errmsg (create-label form "errorMessage"
 387                                       :top-attachment :attach-widget
 388                                       :top-widget errlabel
 389                                       :left-attachment :attach-form
 390                                       :right-attachment :attach-form))
 391          (rlabel (create-label form "restartLabel"
 392                                       :top-attachment :attach-widget
 393                                       :top-widget errmsg
 394                                       :left-attachment :attach-form
 395                                       :font-list *header-font*))
 396          (restarts (create-row-column form "debugRestarts"
 397                                       :adjust-last nil
 398                                       :top-attachment :widget
 399                                       :top-widget rlabel
 400                                       :left-attachment :attach-form
 401                                       :right-attachment :attach-form
 402                                       :left-offset 10))
 403          (btlabel (create-label form "backtraceLabel"
 404                                        :label-string "Stack Backtrace:"
 405                                        :font-list *header-font*
 406                                        :top-attachment :attach-widget
 407                                        :top-widget restarts
 408                                        :left-attachment :attach-form))
 409          (btwindow (create-scrolled-window form "backtraceWindow"
 410                                            :scrolling-policy :automatic
 411                                            :scroll-bar-placement :bottom-right
 412                                            :left-attachment :attach-form
 413                                            :right-attachment :attach-form
 414                                            :left-offset 4
 415                                            :right-offset 4
 416                                            :bottom-offset 4
 417                                            :bottom-attachment :attach-form
 418                                            :top-attachment :attach-widget
 419                                            :top-widget btlabel))
 420          (backtrace (create-row-column btwindow "debugBacktrace"
 421                                        :adjust-last nil
 422                                        :spacing 1)))
 423
 424     (manage-child frame) (manage-child form)
 425     (manage-children menu-bar errlabel errmsg rlabel restarts btlabel btwindow)
 426     (manage-child backtrace)
 427     (manage-child cascade)
 428
 429     (debug-display-error errmsg condition)
 430
 431     (if *debug-restarts*
 432         (progn
 433           (set-values rlabel :label-string "Restarts:")
 434           (debug-display-restarts restarts))
 435         (set-values rlabel :label-string "No restarts available"))
 436
 437     (let ((quick-stack (create-highlight-button backtrace "quickStack"
 438                                                 "Display Stack")))
 439       (add-callback quick-stack :activate-callback
 440                     #'(lambda (w c) (declare (ignore w c))
 441                         (debug-display-stack backtrace)))
 442       (manage-child quick-stack))
 443
 444
 445     (setf *current-debug-display*
 446           (make-debug-display debug-pane errmsg restarts backtrace))
 447
 448     (popup-interface-pane debug-pane)
 449     debug-pane))
 450
 451 ;;; REUSE-DEBUGGER -- Internal
 452 ;;;
 453 ;;; Takes an old debugger pane and a new condition.  It renovates the old
 454 ;;; display to reflect the current debugging state.  This should be used
 455 ;;; whenever possible since it is quite a bit faster than creating a new
 456 ;;; debugger pane from scratch.
 457 ;;;
 458 (defun reuse-debugger (condition info)
 459   (let ((debug-pane (dd-info-debug-pane info))
 460         (errmsg (dd-info-errmsg info))
 461         (restarts (dd-info-restarts info))
 462         (backtrace (dd-info-backtrace info)))
 463
 464     (debug-display-error errmsg condition)
 465     (debug-display-restarts restarts)
 466
 467     (let* ((buttons (xti:widget-children backtrace))
 468            (quick-stack (car buttons)))
 469       (remove-all-callbacks quick-stack :activate-callback)
 470       (set-values quick-stack :label-string "Display Stack")
 471       (add-callback quick-stack :activate-callback
 472                     #'(lambda (w c) (declare (ignore w c))
 473                         (debug-display-stack backtrace)))
 474       (manage-child quick-stack)
 475       (apply #'unmanage-children (cdr buttons)))
 476
 477     (setf *current-debug-display* info)
 478     (popup-interface-pane debug-pane)
 479     debug-pane))
 480
 481 ;;; CREATE-DEBUGGER -- Internal
 482 ;;;
 483 ;;; Creates a graphical debugger display for the given condition.  It will
 484 ;;; attempt to reuse any available old panes.  However, if none are
 485 ;;; available, it will create a new display frame.
 486 ;;;
 487 (defun create-debugger (condition)
 488   (if *old-display-frames*
 489       (reuse-debugger condition (pop *old-display-frames*))
 490       (really-create-debugger condition)))
 491
 492 ;;; CLOSE-MOTIF-DEBUGGER -- Internal
 493 ;;;
 494 ;;; This function should always be called before leaving the context of the
 495 ;;; debugger.  It closes down the frame windows and marks the main debug
 496 ;;; display pane as ready for recycling.
 497 ;;;
 498 (defun close-motif-debugger (condition)
 499   (declare (ignore condition))
 500   (push *current-debug-display* *old-display-frames*)
 501   ;;
 502   ;; Destroy all frame panes
 503   (dolist (info *debug-active-frames*)
 504     (destroy-widget (cdr info)))
 505   (setf *debug-active-frames* nil)
 506   ;;
 507   ;; Remove the restart/backtrace window
 508   (popdown (dd-info-debug-pane *current-debug-display*))
 509   (setf *current-debug-display* nil)
 510
 511   (format t "Leaving debugger.~%"))
 512
 513 ;;; INVOKE-MOTIF-DEBUGGER -- Internal
 514 ;;;
 515 ;;; This function essentially mimics the functions which manage the TTY
 516 ;;; debugger, but uses a graphical debugging display instead.
 517 ;;;
 518 (defun invoke-motif-debugger (condition)
 519   (let* ((*in-the-debugger* t)
 520          (frame (di:top-frame))
 521          (previous-display *current-debug-display*)
 522          (*current-debug-display* nil)
 523          (*debug-active-frames* nil))
 524     (declare (ignore previous-display))
 525     (verify-system-server-exists)
 526     (multiple-value-bind (shell connection)
 527                          (create-interface-shell)
 528       (declare (ignore shell))
 529       (if connection
 530           (with-motif-connection (connection)
 531             (let ((pane (find-interface-pane condition))
 532                   (*current-frame* frame))
 533               (unless pane
 534                 (setf pane (create-debugger condition)))
 535               (unless (is-managed pane)
 536                 (popup-interface-pane pane))
 537               (setf (dd-info-level *current-debug-display*)
 538                     *debug-command-level*)
 539               (setf (dd-info-connection *current-debug-display*) connection)
 540               (unwind-protect
 541                   (handler-case
 542                       (loop
 543                         (system:serve-event))
 544                     (error (err)
 545                            (if *flush-debug-errors*
 546                                (interface-error (safe-condition-message err)
 547                                                 pane)
 548                                (interface-error
 549                                 "Do not yet support recursive debugging"
 550                                 pane))))
 551                 (when (and connection *current-debug-display*)
 552                   (with-motif-connection (connection)
 553                     (close-motif-debugger condition))))))
 554           (invoke-tty-debugger condition)))))
 555
 556 \f
 557
 558 ;;; Used to prevent recursive invocations of the windowing debugger.
 559 ;;;
 560 (defvar *in-windowing-debugger* nil)
 561
 562
 563 ;;; REAL-INVOKE-DEBUGGER -- Internal
 564 ;;;
 565 ;;; Invokes the Lisp debugger.  It decides whether to invoke the TTY
 566 ;;; debugger or the Motif debugger.
 567 ;;;
 568 (defun real-invoke-debugger (condition)
 569   (if (or (not (use-graphics-interface))
 570           *in-windowing-debugger*
 571           (typep condition 'xti:toolkit-error))
 572       (invoke-tty-debugger condition)
 573       (let ((*in-windowing-debugger* t))
 574         (write-line "Invoking debugger...")
 575         (invoke-motif-debugger condition))))