be8ac9f1de1eb5c3e782b6659b117c01a53a2a76
[projects/cmucl/cmucl.git] / 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))))