diff options
author | Neil Jerram <neil@ossau.uklinux.net> | 2004-02-04 12:50:37 +0000 |
---|---|---|
committer | Neil Jerram <neil@ossau.uklinux.net> | 2004-02-04 12:50:37 +0000 |
commit | 15e6a33592258524edfd0e39d4a48c84b6fee462 (patch) | |
tree | 19da641b8f6cd6dbdc1a403bd69b2a0d36fe5fce /emacs | |
parent | 328df3e3bec2aa4d5ef719c7cf6bdb30850c031c (diff) | |
download | guile-15e6a33592258524edfd0e39d4a48c84b6fee462.tar.gz |
* gds.el (gds-handle-client-input): Handle new `thread-status'
protocol.
(gds-display-slow-eval): New.
(gds-client-ref): Bugfix: buf -> (cdr buf).
(gds-display-buffers): Bugfix: minimum overlay end value is 1, not
0.
(gds-evals-in-progress): New.
(gds-results): New.
(gds-insert-interaction): Show evaluations in progress (with
button to interrupt them) and results of last help or evaluation.
(gds-interrupt-eval): New.
(gds-debug-trap-hooks, gds-up, gds-down): New.
(gds-eval-region, gds-eval-expression): Include abbreviated code
in eval correlator.
(gds-abbreviated-length, gds-abbreviated): New.
(gds-mode-map): New keys for gds-debug-trap-hooks, gds-up,
gds-down.
(gds-debug-menu): New menu entries for gds-up, gds-down.
* gds-client.scm (gds-connect): Enable trapping for gds-eval
stacks.
(ui-read-thread-proc): Write 'running status earlier.
(stack->emacs-readable): Limit stack length to 'depth debug
option.
(handle-instruction): Update format of eval correlator.
(handle-instruction-1): Resolve module names from root module
instead of from current module.
(resolve-module-from-root): New.
(handle-instruction-1): New protocol `interrupt-eval'.
(eval-thread-table): New.
(eval-thread): Add thread to eval-thread-table; write new protocol
to frontend to communicate eval thread status; update for new
correlator format; bind correlator local before entering loop2.
(gds-eval): Use start-stack 'gds-eval-stack to rebase stack.
* gds.el (gds-start, gds-start-captive): Do
`process-kill-without-query' as soon as processes started, ...
(gds-shutdown, gds-kill-captive): ... instead of here.
(gds-display-results): More clearly show unspecified results; show
results in interaction view instead of in separate window.
(gds-send): Add sent protocol to transcript.
Diffstat (limited to 'emacs')
-rw-r--r-- | emacs/.cvsignore | 4 | ||||
-rw-r--r-- | emacs/ChangeLog | 44 | ||||
-rw-r--r-- | emacs/gds-client.scm | 56 | ||||
-rw-r--r-- | emacs/gds.el | 195 |
4 files changed, 240 insertions, 59 deletions
diff --git a/emacs/.cvsignore b/emacs/.cvsignore index 282522db0..d6870b18c 100644 --- a/emacs/.cvsignore +++ b/emacs/.cvsignore @@ -1,2 +1,6 @@ Makefile Makefile.in +version.texi +*.info +stamp-vti +mdate-sh diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 33968667e..544065acd 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,47 @@ +2004-01-28 Neil Jerram <neil@ossau.uklinux.net> + + * gds.el (gds-handle-client-input): Handle new `thread-status' + protocol. + (gds-display-slow-eval): New. + (gds-client-ref): Bugfix: buf -> (cdr buf). + (gds-display-buffers): Bugfix: minimum overlay end value is 1, not + 0. + (gds-evals-in-progress): New. + (gds-results): New. + (gds-insert-interaction): Show evaluations in progress (with + button to interrupt them) and results of last help or evaluation. + (gds-interrupt-eval): New. + (gds-debug-trap-hooks, gds-up, gds-down): New. + (gds-eval-region, gds-eval-expression): Include abbreviated code + in eval correlator. + (gds-abbreviated-length, gds-abbreviated): New. + (gds-mode-map): New keys for gds-debug-trap-hooks, gds-up, + gds-down. + (gds-debug-menu): New menu entries for gds-up, gds-down. + + * gds-client.scm (gds-connect): Enable trapping for gds-eval + stacks. + (ui-read-thread-proc): Write 'running status earlier. + (stack->emacs-readable): Limit stack length to 'depth debug + option. + (handle-instruction): Update format of eval correlator. + (handle-instruction-1): Resolve module names from root module + instead of from current module. + (resolve-module-from-root): New. + (handle-instruction-1): New protocol `interrupt-eval'. + (eval-thread-table): New. + (eval-thread): Add thread to eval-thread-table; write new protocol + to frontend to communicate eval thread status; update for new + correlator format; bind correlator local before entering loop2. + (gds-eval): Use start-stack 'gds-eval-stack to rebase stack. + + * gds.el (gds-start, gds-start-captive): Do + `process-kill-without-query' as soon as processes started, ... + (gds-shutdown, gds-kill-captive): ... instead of here. + (gds-display-results): More clearly show unspecified results; show + results in interaction view instead of in separate window. + (gds-send): Add sent protocol to transcript. + 2004-01-26 Neil Jerram <neil@ossau.uklinux.net> * gds.el (gds-request-focus, gds-quit): Simplify. Old algorithm diff --git a/emacs/gds-client.scm b/emacs/gds-client.scm index a1bcf7220..ba4d58737 100644 --- a/emacs/gds-client.scm +++ b/emacs/gds-client.scm @@ -23,6 +23,7 @@ #:use-module (ice-9 debugger breakpoints procedural) #:use-module (ice-9 debugger breakpoints source) #:use-module (ice-9 debugger state) + #:use-module (ice-9 debugger trap-hooks) #:use-module (ice-9 debugger utils) #:use-module (ice-9 optargs) #:use-module (ice-9 regex) @@ -101,6 +102,7 @@ decimal IP address where the UI server is running; default is "w")) ;; Announce ourselves to the server. (write-form (list 'name name (getpid))) + (add-trapped-stack-id! 'gds-eval-stack) ;; Start the UI read thread. (set! ui-read-thread (make-thread ui-read-thread-proc))) @@ -124,6 +126,7 @@ decimal IP address where the UI server is running; default is ;; this purpose. This design avoids having to modify application code ;; at the expense of requiring a Guile with threads support. (define (ui-read-thread-proc) + (write-status 'running) (let ((eval-thread-needed? #t)) ;; Start up the default eval thread. (make-thread eval-thread 1 (lambda () (not eval-thread-needed?))) @@ -269,7 +272,8 @@ decimal IP address where the UI server is running; default is ;; Return Emacs-readable representation of STACK. (map (lambda (index) (frame->emacs-readable (stack-ref stack index))) - (iota (stack-length stack)))) + (iota (min (stack-length stack) + (cadr (memq 'depth (debug-options))))))) (define (frame->emacs-readable frame) ;; Return Emacs-readable representation of FRAME. @@ -336,7 +340,7 @@ decimal IP address where the UI server is running; default is (apply throw key args)) (else (write-form - `(eval-results error + `(eval-results (error . "") "GDS Internal Error\n" ,(list (with-output-to-string (lambda () @@ -373,7 +377,7 @@ decimal IP address where the UI server is running; default is ,(or (loaded-module-source name) "(no source file)") ,@(sort (module-map (lambda (key value) (symbol->string key)) - (resolve-module name)) + (resolve-module-from-root name)) string<?)))) state) ((debugger-command) @@ -397,7 +401,7 @@ decimal IP address where the UI server is running; default is (display (cadddr ins)) (display "' behaviour; doing `debug-here' instead.\n") (debug-here)))) - (module-ref (resolve-module (cadr ins)) (caddr ins))) + (module-ref (resolve-module-from-root (cadr ins)) (caddr ins))) state) ((eval) (apply (lambda (correlator module port-name line column bpinfo code) @@ -406,7 +410,7 @@ decimal IP address where the UI server is running; default is (set-port-filename! (current-input-port) port-name) (set-port-line! (current-input-port) line) (set-port-column! (current-input-port) column) - (let ((m (and module (resolve-module module)))) + (let ((m (and module (resolve-module-from-root module)))) (let loop ((exprs '()) (x (read))) (if (eof-object? x) ;; Expressions to be evaluated have all been @@ -468,11 +472,23 @@ decimal IP address where the UI server is running; default is (debug-stack (make-stack #t 3) #:continuable)) thread)) state) + ((interrupt-eval) + (let ((thread (hash-ref eval-thread-table (cadr ins)))) + (system-async-mark (lambda () + (debug-stack (make-stack #t 3) #:continuable)) + thread)) + state) (else state))) (define the-ice-9-debugger-commands-module (resolve-module '(ice-9 debugger commands))) +(define (resolve-module-from-root name) + (save-module-excursion + (lambda () + (set-current-module the-root-module) + (resolve-module name)))) + ;;;; {Module Browsing} @@ -565,12 +581,19 @@ decimal IP address where the UI server is running; default is (set! count (+ count 1)) count))) +(define eval-thread-table (make-hash-table 3)) + (define (eval-thread depth thread-should-exit-thunk) ;; Acquire mutex to check trigger variables. (with-mutex eval-work-mutex (let ((thread-number (next-thread-number))) + ;; Add this thread to global hash, so we can correlate back to + ;; this thread from the ID used by the GDS front end. + (hash-set! eval-thread-table thread-number (current-thread)) (trc 'eval-thread depth thread-number "entering loop") (let loop () + ;; Tell the front end this thread is ready. + (write-form `(thread-status eval ,thread-number ready)) (cond ((thread-should-exit-thunk) ;; Allow thread to exit. ) @@ -579,8 +602,11 @@ decimal IP address where the UI server is running; default is ;; Take a local copy of the work, reset global ;; variables, then do the work with mutex released. (trc 'eval-thread depth thread-number "starting work") - (let ((work eval-work) - (subthread-needed? #t)) + (let* ((work eval-work) + (subthread-needed? #t) + (correlator (car work))) + ;; Tell the front end this thread is busy. + (write-form `(thread-status eval ,thread-number busy ,correlator)) (set! eval-work-available #f) (signal-condition-variable eval-work-taken) (without-mutex eval-work-mutex @@ -591,14 +617,12 @@ decimal IP address where the UI server is running; default is (make-thread eval-thread (+ depth 1) (lambda () (not subthread-needed?))) ;; Do the evaluation(s). - (let loop2 ((correlator (car work)) - (m (cadr work)) + (let loop2 ((m (cadr work)) (exprs (cddr work)) (results '())) (if (null? exprs) (write-form `(eval-results ,correlator ,@results)) - (loop2 correlator - m + (loop2 m (cdr exprs) (append results (gds-eval (car exprs) m)))))) (trc 'eval-thread depth thread-number "work done") @@ -615,7 +639,9 @@ decimal IP address where the UI server is running; default is (wait-condition-variable eval-work-changed eval-work-mutex) (trc 'eval-thread depth thread-number "wait done") (loop)))) - (trc 'eval-thread depth thread-number "exiting")))) + (trc 'eval-thread depth thread-number "exiting") + ;; Tell the front end this thread is ready. + (write-form `(thread-status eval ,thread-number exiting))))) (define (gds-eval x m) ;; Consumer to accept possibly multiple values and present them for @@ -635,7 +661,8 @@ decimal IP address where the UI server is running; default is (newline) (set! value (call-with-values (lambda () - (eval x m)) + (start-stack 'gds-eval-stack + (eval x m))) value-consumer))) (lambda () (display "Evaluating in current module ") @@ -643,7 +670,8 @@ decimal IP address where the UI server is running; default is (newline) (set! value (call-with-values (lambda () - (primitive-eval x)) + (start-stack 'gds-eval-stack + (primitive-eval x))) value-consumer))))) (output (with-output-to-string diff --git a/emacs/gds.el b/emacs/gds.el index c22d99ff6..2c0d80f58 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -61,7 +61,8 @@ (setq gds-read-cursor (point-min)) (set-process-filter gds-process (function gds-filter)) (set-process-sentinel gds-process (function gds-sentinel)) - (set-process-coding-system gds-process 'latin-1-unix)) + (set-process-coding-system gds-process 'latin-1-unix) + (process-kill-without-query gds-process)) ;; Shutdown the subprocess and cleanup all associated data. (defun gds-shutdown () @@ -70,7 +71,6 @@ ;; Reset variables. (setq gds-buffers nil) ;; Kill the subprocess. - (process-kill-without-query gds-process) (condition-case nil (progn (kill-process gds-process) @@ -104,7 +104,13 @@ ;; Send input to the subprocess. (defun gds-send (string client) - (process-send-string gds-process (format "(%S %s)\n" client string))) + (process-send-string gds-process (format "(%S %s)\n" client string)) + (let ((buf (gds-client-ref 'gds-transcript))) + (if buf + (with-current-buffer buf + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "tx (%S %s)\n" client string))))))) ;;;; Focussing in and out on interaction with a particular client. @@ -314,8 +320,38 @@ The function is called with one argument, the CLIENT in question." (setq os nil)) (setq os (cdr os))))))))) + (;; (thread-status THREAD-TYPE THREAD-NUMBER STATUS [CORRELATOR]) + (eq proc 'thread-status) + (if (eq (car args) 'eval) + (let ((number (nth 1 args)) + (status (nth 2 args)) + (correlator (nth 3 args))) + (if (eq status 'busy) + (progn + (setq gds-evals-in-progress + (append gds-evals-in-progress + (list (cons number correlator)))) + (run-at-time 0.5 nil + (function gds-display-slow-eval) + buf number correlator) + (gds-promote-view 'interaction)) + (let ((existing (assq number gds-evals-in-progress))) + (if existing + (setq gds-evals-in-progress + (delq existing gds-evals-in-progress))))) + (gds-update-buffers)))) + ))) +(defun gds-display-slow-eval (buf number correlator) + (with-current-buffer buf + (let ((entry (assq number gds-evals-in-progress))) + (if (and entry + (eq (cdr entry) correlator)) + (progn + (gds-promote-view 'interaction) + (gds-request-focus gds-client)))))) + ;;;; Per-client buffer state. @@ -379,7 +415,7 @@ The function is called with one argument, the CLIENT in question." (and buf (cdr buf) (buffer-live-p (cdr buf)) - (with-current-buffer buf + (with-current-buffer (cdr buf) (symbol-value sym)))))) (defun gds-client-blocked () @@ -439,7 +475,7 @@ The function is called with one argument, the CLIENT in question." ;; If there is an associated source buffer, display it as well. (if (and (eq (car gds-views) 'stack) gds-frame-source-overlay - (> (overlay-end gds-frame-source-overlay) 0)) + (> (overlay-end gds-frame-source-overlay) 1)) (let ((window (display-buffer (overlay-buffer gds-frame-source-overlay)))) (set-window-point window @@ -505,6 +541,14 @@ the following symbols. "The exception keys for which to debug a GDS client.") (make-variable-buffer-local 'gds-exception-keys) +(defvar gds-evals-in-progress nil + "Alist describing evaluations in progress.") +(make-variable-buffer-local 'gds-evals-in-progress) + +(defvar gds-results nil + "Last help or evaluation results.") +(make-variable-buffer-local 'gds-results) + (defun gds-insert-interaction () (erase-buffer) ;; Insert stuff for interacting with a running (non-blocked) Guile @@ -534,7 +578,18 @@ the following symbols. (widget-create 'editable-field :notify (function gds-set-exception-keys) gds-exception-keys) - (widget-insert "\n")) + (let ((evals gds-evals-in-progress)) + (if evals + (widget-insert "\nEvaluations in progress:\n")) + (while evals + (let ((w (widget-create 'push-button + :notify (function gds-interrupt-eval) + "Interrupt"))) + (widget-put w :thread-number (caar evals)) + (widget-insert " " (cddar evals) "\n")) + (setq evals (cdr evals)))) + (if gds-results + (widget-insert "\n" (cdr gds-results)))) (defun gds-sigint (w &rest ignore) (interactive) @@ -544,6 +599,11 @@ the following symbols. (interactive) (gds-send "async-break" gds-client)) +(defun gds-interrupt-eval (w &rest ignore) + (interactive) + (gds-send (format "interrupt-eval %S" (widget-get w :thread-number)) + gds-client)) + (defun gds-toggle-debug-exceptions (w &rest ignore) (interactive) (setq gds-debug-exceptions (widget-value w)) @@ -815,6 +875,18 @@ are not readable by Emacs.") (interactive) (gds-send "debugger-command info-args" gds-client)) +(defun gds-debug-trap-hooks () + (interactive) + (gds-send "debugger-command debug-trap-hooks" gds-client)) + +(defun gds-up () + (interactive) + (gds-send "debugger-command up 1" gds-client)) + +(defun gds-down () + (interactive) + (gds-send "debugger-command down 1" gds-client)) + ;;;; Setting breakpoints. @@ -1107,26 +1179,45 @@ region's code." (setq column (current-column)) ; 0-based (beginning-of-line) (setq line (count-lines (point-min) (point)))) ; 0-based - (gds-send (format "eval region %s %S %d %d %s %S" - (if module (prin1-to-string module) "#f") - port-name line column - (let ((bpinfo (gds-region-breakpoint-info start end))) - ;; Make sure that "no bpinfo" is represented - ;; as "()", not "nil", as Scheme doesn't - ;; understand "nil". - (if bpinfo (format "%S" bpinfo) "()")) - (buffer-substring-no-properties start end)) - client))) + (let ((code (buffer-substring-no-properties start end))) + (gds-send (format "eval (region . %S) %s %S %d %d %s %S" + (gds-abbreviated code) + (if module (prin1-to-string module) "#f") + port-name line column + (let ((bpinfo (gds-region-breakpoint-info start end))) + ;; Make sure that "no bpinfo" is represented + ;; as "()", not "nil", as Scheme doesn't + ;; understand "nil". + (if bpinfo (format "%S" bpinfo) "()")) + code) + client)))) (defun gds-eval-expression (expr &optional client correlator) "Evaluate the supplied EXPR (a string)." (interactive "sEvaluate expression: \nP") (setq client (gds-choose-client client)) - (gds-send (format "eval %S #f \"Emacs expression\" 0 0 () %S" + (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 () %S" (or correlator 'expression) + (gds-abbreviated expr) expr) client)) +(defconst gds-abbreviated-length 35) + +(defun gds-abbreviated (code) + (let ((nlpos (string-match (regexp-quote "\n") code))) + (while nlpos + (setq code + (if (= nlpos (- (length code) 1)) + (substring code 0 nlpos) + (concat (substring code 0 nlpos) + "\\n" + (substring code (+ nlpos 1))))) + (setq nlpos (string-match (regexp-quote "\n") code)))) + (if (> (length code) gds-abbreviated-length) + (concat (substring code 0 (- gds-abbreviated-length 3)) "...") + code)) + (defun gds-eval-defun (&optional client) "Evaluate the defun (top-level form) at point." (interactive "P") @@ -1219,29 +1310,38 @@ interesting happened, `nil' if not." ;;;; Display of evaluation and help results. (defun gds-display-results (client correlator results) - (let ((helpp (eq correlator 'help))) + (let ((helpp (eq (car correlator) 'help))) (let ((buf (get-buffer-create (if helpp "*Guile Help*" "*Guile Results*")))) - (save-excursion - (set-buffer buf) - (erase-buffer) - (scheme-mode) - (while results - (insert (car results)) - (if helpp - nil - (mapcar (function (lambda (value) - (insert " => " value "\n"))) - (cadr results)) - (insert "\n")) - (setq results (cddr results))) - (goto-char (point-min)) - (if (and helpp (looking-at "Evaluating in ")) - (delete-region (point) (progn (forward-line 1) (point))))) - (pop-to-buffer buf) - (run-hooks 'temp-buffer-show-hook) - (other-window 1)))) + (setq gds-results + (save-excursion + (set-buffer buf) + (erase-buffer) + (scheme-mode) + (insert (cdr correlator) "\n\n") + (while results + (insert (car results)) + (or (bolp) (insert "\\\n")) + (if helpp + nil + (if (cadr results) + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert " => no (or unspecified) value\n")) + (insert "\n")) + (setq results (cddr results))) + (goto-char (point-min)) + (if (and helpp (looking-at "Evaluating in ")) + (delete-region (point) (progn (forward-line 1) (point)))) + (cons correlator (buffer-string)))) + ;;(pop-to-buffer buf) + ;;(run-hooks 'temp-buffer-show-hook) + ;;(other-window 1) + )) + (gds-promote-view 'interaction) + (gds-request-focus client)) ;;;; Loading (evaluating) a whole Scheme file. @@ -1301,7 +1401,9 @@ Used for determining the default for the next `gds-load-file'.") (define-key gds-mode-map "t" (function gds-trace-finish)) (define-key gds-mode-map "I" (function gds-frame-info)) (define-key gds-mode-map "A" (function gds-frame-args)) - +(define-key gds-mode-map "H" (function gds-debug-trap-hooks)) +(define-key gds-mode-map "u" (function gds-up)) +(define-key gds-mode-map "d" (function gds-down)) (define-key gds-mode-map "b" (function gds-set-breakpoint)) (define-key gds-mode-map "vi" (function gds-view-interaction)) @@ -1338,6 +1440,10 @@ Used for determining the default for the next `gds-load-file'.") (setq gds-debug-menu (make-sparse-keymap "Debug")) (define-key gds-debug-menu [go] '(menu-item "Go" gds-go)) + (define-key gds-debug-menu [down] + '(menu-item "Move Down 1 Frame" gds-down)) + (define-key gds-debug-menu [up] + '(menu-item "Move Up 1 Frame" gds-up)) (define-key gds-debug-menu [trace-finish] '(menu-item "Trace This Frame" gds-trace-finish)) (define-key gds-debug-menu [step-out] @@ -1464,6 +1570,7 @@ Used for determining the default for the next `gds-load-file'.") nil "-q"))) (let ((proc (get-buffer-process gds-captive))) + (process-kill-without-query proc) (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") (comint-send-string proc "(debug-enable 'backtrace)\n") (comint-send-string proc "(use-modules (emacs gds-client))\n") @@ -1471,13 +1578,11 @@ Used for determining the default for the next `gds-load-file'.") (defun gds-kill-captive () (if gds-captive - (let ((proc (get-buffer-process gds-captive))) - (process-kill-without-query proc) - (condition-case nil - (progn - (kill-process proc) - (accept-process-output gds-process 0 200)) - (error))))) + (condition-case nil + (progn + (kill-process (get-buffer-process gds-captive)) + (accept-process-output gds-process 0 200)) + (error)))) ;;;; The end! |