mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Implement eval threads.

Browse source
This commit is contained in:
Neil Jerram 2004-01-20 22:09:32 +00:00
parent 5c963b6eb8
commit a6ab1debaf
2 changed files with 328 additions and 166 deletions
Download patch file Download diff file Expand all files Collapse all files

5
emacs/ChangeLog
View file

@ -1,3 +1,8 @@
2004-01-20 Neil Jerram <neil@ossau.uklinux.net>
* gds-client.scm: Extensive changes to implement eval threads, and
to tidy up and organize the rest of the code.
2003-12-06 Neil Jerram <neil@ossau.uklinux.net> 2003-12-06 Neil Jerram <neil@ossau.uklinux.net>
* gds.texi: New. * gds.texi: New.

489
emacs/gds-client.scm
View file

@ -1,6 +1,6 @@
;;;; Guile Debugger UI client ;;;; Guile Debugger UI client
;;; Copyright (C) 2003 Free Software Foundation, Inc. ;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
;;; ;;;
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -36,16 +36,48 @@
gds-server-died-hook) gds-server-died-hook)
#:no-backtrace) #:no-backtrace)
;; The TCP port number that the UI server listens for application
;; connections on. ;;;; {Internal Tracing and Debugging}
;; Some of this module's thread and mutex code is quite tricky and
;; includes `trc' statements to trace out useful information if the
;; environment variable GDS_TRC is defined.
(define trc
(if (getenv "GDS_TRC")
(let ((port (open-output-file "/home/neil/gds-client.log"))
(trc-mutex (make-mutex)))
(lambda args
(with-mutex trc-mutex
(write args port)
(newline port)
(force-output port))))
noop))
(define-macro (assert expr)
`(or ,expr
(error "Assertion failed" expr)))
;;;; {TCP Connection}
;; Communication between this module (running in the application being
;; debugged) and the GDS server and UI code (running in/under Emacs)
;; is through a TCP connection. `gds-port-number' is the TCP port
;; number where the server listens for application connections.
(define gds-port-number 8333) (define gds-port-number 8333)
;; Once connected, the TCP socket port to the UI server. ;; Once connected, the TCP socket port to the server.
(define gds-port #f) (define gds-port #f)
(define* (gds-connect name debug #:optional host) ;; Public procedure to discover whether there is a GDS connection yet.
"Connect to the debug UI server as @var{name}, a string that should (define (gds-connected?)
be sufficient to describe the calling application to the debug UI "Return @code{#t} if a UI server connected has been made; else @code{#f}."
(not (not gds-port)))
;; Public procedure to create the connection to the GDS server.
(define* (gds-connect name #:optional host)
"Connect to the GDS server as @var{name}, a string that should be
sufficient to describe the calling application to the GDS frontend
user. The optional @var{host} arg specifies the hostname or dotted user. The optional @var{host} arg specifies the hostname or dotted
decimal IP address where the UI server is running; default is decimal IP address where the UI server is running; default is
127.0.0.1." 127.0.0.1."
@ -59,96 +91,18 @@ decimal IP address where the UI server is running; default is
(setsockopt s SOL_TCP TCP_NODELAY 1) (setsockopt s SOL_TCP TCP_NODELAY 1)
(connect s AF_INET (inet-aton (or host "127.0.0.1")) gds-port-number) (connect s AF_INET (inet-aton (or host "127.0.0.1")) gds-port-number)
s)) s))
;; Set debugger-output-port so that stuff written to it is ;; Set debugger-output-port so that messages written to it are not
;; accumulated for sending to the debug server. ;; displayed on the application's stdout, but instead accumulated
;; for sending to the GDS frontend.
(set! (debugger-output-port) (set! (debugger-output-port)
(make-soft-port (vector accumulate-output (make-soft-port (vector accumulate-output
accumulate-output accumulate-output
#f #f #f #f) #f #f #f #f)
"w")) "w"))
;; Write initial context to debug server. ;; Announce ourselves to the server.
(write-form (list 'name name (getpid))) (write-form (list 'name name (getpid)))
;(write-form (cons 'modules (map module-name (loaded-modules)))) ;; Start the UI read thread.
;; Start the asynchronous UI thread. (set! ui-read-thread (make-thread ui-read-thread-proc)))
(start-async-gds-thread)
;; If `debug' is true, debug immediately.
(if debug
(debug-stack (make-stack #t gds-connect) #:continuable))
; (gds-command-loop #f)
)
(define gds-disable-async-thread noop)
(define gds-continue-async-thread noop)
(define async-gds-thread #f)
(define (start-async-gds-thread)
(let ((mutex (make-mutex))
(condition (make-condition-variable))
(admin (pipe)))
;; Start the asynchronous UI thread.
(begin-thread
(set! async-gds-thread (current-thread))
;;(write (cons admin gds-port))
;;(newline)
(lock-mutex mutex)
(catch 'server-died
(lambda ()
(let loop ((avail '()))
(write-note 'startloop)
;;(write avail)
;;(newline)
(cond ((not gds-port)) ; exit loop
((null? avail)
(write-status 'ready-for-input)
(unlock-mutex mutex)
(let ((ports (car (select (list gds-port (car admin))
'() '()))))
(lock-mutex mutex)
(loop ports)))
(else
(write-note 'sthg-to-read)
(let ((port (car avail)))
(if (eq? port gds-port)
(handle-instruction #f (read gds-port))
(begin
(write-note 'debugger-takeover)
;; Notification from debugger that it
;; wants to take over. Read the
;; notification char.
(read-char (car admin))
;; Wait on condition variable - this allows the
;; debugger thread to grab the mutex.
(write-note 'cond-wait)
(signal-condition-variable condition)
(wait-condition-variable condition mutex)
))
;; Loop.
(loop '()))))
(write-note 'loopexited)))
(lambda args #f))
(set! gds-disable-async-thread noop)
(set! gds-continue-async-thread noop)
(set! async-gds-thread #f)
(unlock-mutex mutex))
;; Redefine procs used by debugger thread to take control.
(set! gds-disable-async-thread
(lambda ()
(lock-mutex mutex)
(write-char #\x (cdr admin))
(force-output (cdr admin))
(write-note 'char-written)
(wait-condition-variable condition mutex)
;;(display "gds-disable-async-thread: locking mutex...\n"
;; (current-error-port))
))
(set! gds-continue-async-thread
(lambda ()
(write-note 'cond-signal)
(signal-condition-variable condition)
;; Make sure that the async thread has got the message
;; before we could possibly try to grab the main mutex
;; again.
(unlock-mutex mutex)))))
(define accumulated-output '()) (define accumulated-output '())
@ -162,31 +116,135 @@ decimal IP address where the UI server is running; default is
(set! accumulated-output '()) (set! accumulated-output '())
s)) s))
(define (gds-connected?)
"Return @code{#t} if a UI server connected has been made; else @code{#f}."
(not (not gds-port)))
;;;; {UI Read Thread}
;; Except when the application enters the debugger, communication with
;; the GDS server and frontend is managed by a dedicated thread for
;; 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)
(let ((eval-thread-needed? #t))
;; Start up the default eval thread.
(make-thread eval-thread 1 (lambda () (not eval-thread-needed?)))
(with-mutex ui-read-mutex
(catch 'server-died
;; Protected thunk: loop reading either protocol input from
;; the server, or an indication (through ui-read-switch-pipe)
;; that a thread in the debugger wants to take over the
;; interaction with the server.
(lambda ()
(let loop ((avail '()))
(write-note 'startloop)
(cond ((not gds-port)) ; exit loop
((null? avail)
(write-status 'ready-for-input)
(loop (without-mutex ui-read-mutex
(car (select (list gds-port
(car ui-read-switch-pipe))
'() '())))))
(else
(write-note 'sthg-to-read)
(let ((port (car avail)))
(if (eq? port gds-port)
(handle-instruction #f (read gds-port))
(begin
(write-note 'debugger-takeover)
;; Notification from debugger that it wants
;; to take over. Read the notification
;; char.
(read-char (car ui-read-switch-pipe))
;; Wait on ui-read-switch variable - this
;; allows the debugger thread to grab the
;; mutex.
(write-note 'cond-wait)
(signal-condition-variable ui-read-switch)
(wait-condition-variable ui-read-switch
ui-read-mutex)))
;; Loop.
(loop '()))))
(write-note 'loopexited)))
;; Catch handler.
(lambda args #f)))
;; Tell the eval thread that it can exit.
(with-mutex eval-work-mutex
(set! eval-thread-needed? #f)
(broadcast-condition-variable eval-work-changed))))
;; It's useful to keep a note of the UI thread's id.
(define ui-read-thread #f)
;; Mutex used to control which thread is currently reading the TCP
;; connection to the server/UI.
(define ui-read-mutex (make-mutex))
;; Condition variable used by threads interested in reading the TCP
;; connection to signal changes in their state.
(define ui-read-switch (make-condition-variable))
;; Pipe used by application threads that enter the debugger to tell
;; the UI read thread that they'd like to take over reading the TCP
;; connection.
(define ui-read-switch-pipe (pipe))
;;;; {Debugger Integration}
;; When a thread enters the Guile debugger and a GDS connection is
;; present, the debugger calls `gds-command-loop' instead of entering
;; its usual command loop.
(define (gds-command-loop state) (define (gds-command-loop state)
"Interact with the UI frontend." "Interact with the UI frontend."
(or (gds-connected?) (or (gds-connected?)
(error "Not connected to UI server.")) (error "Not connected to UI server."))
(gds-disable-async-thread) ;; Take over server/UI interaction from the normal UI read thread.
(catch #t ; Only expect here 'exit-debugger or 'server-died. (with-mutex ui-read-mutex)
(lambda () (write-char #\x (cdr ui-read-switch-pipe))
(let loop ((state state)) (force-output (cdr ui-read-switch-pipe))
;; Write accumulated debugger output. (write-note 'char-written)
(write-form (list 'output (wait-condition-variable ui-read-switch ui-read-mutex)
(sans-surrounding-whitespace ;; We now "have the com", as they say on Star Trek.
(get-accumulated-output)))) (catch #t ; Only expect here 'exit-debugger or 'server-died.
;; Write current state to the frontend. (lambda ()
(if state (write-stack state)) (let loop ((state state))
;; Tell the frontend that we're waiting for input. ;; Write accumulated debugger output.
(write-status 'waiting-for-input) (write-form (list 'output (sans-surrounding-whitespace
;; Read next instruction, act on it, and loop with (get-accumulated-output))))
;; updated state. ;; Write current state to the frontend.
(loop (handle-instruction state (read gds-port))))) (if state (write-stack state))
(lambda args *unspecified*)) ;; Tell the frontend that we're waiting for input.
(gds-continue-async-thread)) (write-status 'waiting-for-input)
;; Read next instruction, act on it, and loop with updated
;; state.
(loop (handle-instruction state (read gds-port)))))
(lambda args *unspecified*))
(write-note 'cond-signal)
;; Tell the UI read thread that it can take control again.
(signal-condition-variable ui-read-switch))
;;;; {General Output to Server/UI}
(define write-form
(let ((protocol-mutex (make-mutex)))
(lambda (form)
;; Write any form FORM to UI frontend.
(with-mutex protocol-mutex
(write form gds-port)
(newline gds-port)
(force-output gds-port)))))
(define (write-note note)
;; Write a note (for debugging this code) to UI frontend.
(false-if-exception (write-form `(note ,note))))
(define (write-status status)
(write-form (list 'current-module
(format #f "~S" (module-name (current-module)))))
(write-form (list 'status status)))
;;;; {Stack Output to Server/UI}
(define (write-stack state) (define (write-stack state)
;; Write Emacs-readable representation of current state to UI ;; Write Emacs-readable representation of current state to UI
@ -207,16 +265,6 @@ decimal IP address where the UI server is running; default is
(- nframes index 1) (- nframes index 1)
flags)))))) flags))))))
(define (write-form form)
;; Write any form FORM to UI frontend.
(write form gds-port)
(newline gds-port)
(force-output gds-port))
(define (write-note note)
;; Write a note (for debugging this code) to UI frontend.
(false-if-exception (write-form `(note ,note))))
(define (stack->emacs-readable stack) (define (stack->emacs-readable stack)
;; Return Emacs-readable representation of STACK. ;; Return Emacs-readable representation of STACK.
(map (lambda (index) (map (lambda (index)
@ -266,11 +314,11 @@ decimal IP address where the UI server is running; default is
(format #f "~S" flag))) (format #f "~S" flag)))
flags)) flags))
(define the-ice-9-debugger-commands-module
(resolve-module '(ice-9 debugger commands)))
(define internal-error-stack #f) ;;;; {Handling GDS Protocol Instructions}
;; Instructions from the server/UI always come through here. If
;; `state' is non-#f, we are in the debugger; otherwise, not.
(define (handle-instruction state ins) (define (handle-instruction state ins)
(if (eof-object? ins) (if (eof-object? ins)
(server-died) (server-died)
@ -288,7 +336,8 @@ decimal IP address where the UI server is running; default is
(apply throw key args)) (apply throw key args))
(else (else
(write-form (write-form
`(eval-results "GDS Internal Error\n" `(eval-results error
"GDS Internal Error\n"
,(list (with-output-to-string ,(list (with-output-to-string
(lambda () (lambda ()
(write key) (write key)
@ -306,6 +355,8 @@ decimal IP address where the UI server is running; default is
(run-hook gds-server-died-hook) (run-hook gds-server-died-hook)
(throw 'server-died)) (throw 'server-died))
(define internal-error-stack #f)
(define gds-server-died-hook (make-hook)) (define gds-server-died-hook (make-hook))
(define (handle-instruction-1 state ins) (define (handle-instruction-1 state ins)
@ -326,6 +377,7 @@ decimal IP address where the UI server is running; default is
string<?)))) string<?))))
state) state)
((debugger-command) ((debugger-command)
(or state (error "Not currently in debugger!"))
(write-status 'running) (write-status 'running)
(let ((name (cadr ins)) (let ((name (cadr ins))
(args (cddr ins))) (args (cddr ins)))
@ -348,18 +400,33 @@ decimal IP address where the UI server is running; default is
(module-ref (resolve-module (cadr ins)) (caddr ins))) (module-ref (resolve-module (cadr ins)) (caddr ins)))
state) state)
((eval) ((eval)
(apply (lambda (module port-name line column bpinfo code) (apply (lambda (correlator module port-name line column bpinfo code)
(with-input-from-string code (with-input-from-string code
(lambda () (lambda ()
(set-port-filename! (current-input-port) port-name) (set-port-filename! (current-input-port) port-name)
(set-port-line! (current-input-port) line) (set-port-line! (current-input-port) line)
(set-port-column! (current-input-port) column) (set-port-column! (current-input-port) column)
(let ((m (and module (resolve-module module)))) (let ((m (and module (resolve-module module))))
(let loop ((results '()) (x (read))) (let loop ((exprs '()) (x (read)))
(if (eof-object? x) (if (eof-object? x)
(write-form `(eval-results ,@results)) ;; Expressions to be evaluated have all been
(loop (append results (gds-eval x bpinfo m)) ;; read. Now hand them off to an
(read)))))))) ;; eval-thread for the actual evaluation.
(with-mutex eval-work-mutex
(trc 'protocol-thread "evaluation work available")
(set! eval-work (cons* correlator m (reverse! exprs)))
(set! eval-work-available #t)
(broadcast-condition-variable eval-work-changed)
(wait-condition-variable eval-work-taken
eval-work-mutex)
(assert (not eval-work-available))
(trc 'protocol-thread "evaluation work underway"))
;; Another complete expression read. Set
;; breakpoints in the read code as specified
;; by bpinfo, and add it to the list.
(begin
(install-breakpoints x bpinfo)
(loop (cons x exprs) (read)))))))))
(cdr ins)) (cdr ins))
state) state)
((complete) ((complete)
@ -392,10 +459,10 @@ decimal IP address where the UI server is running; default is
,match))))))) ,match)))))))
state) state)
((async-break) ((async-break)
(let ((thread (car (delq async-gds-thread (all-threads))))) (let ((thread (car (delq ui-read-thread (all-threads)))))
(write (cons 'target-thread thread)) (write (cons 'target-thread thread))
(newline) (newline)
(write (cons 'async-thread async-gds-thread)) (write (cons 'ui-read-thread ui-read-thread))
(newline) (newline)
(system-async-mark (lambda () (system-async-mark (lambda ()
(debug-stack (make-stack #t 3) #:continuable)) (debug-stack (make-stack #t 3) #:continuable))
@ -403,6 +470,41 @@ decimal IP address where the UI server is running; default is
state) state)
(else state))) (else state)))
(define the-ice-9-debugger-commands-module
(resolve-module '(ice-9 debugger commands)))
;;;; {Module Browsing}
(define (loaded-module-source module-name)
;; Return the file name that (ice-9 boot-9) probably loaded the
;; named module from. (The `probably' is because `%load-path' might
;; have changed since the module was loaded.)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(string-append (symbol->string elt) "/"))
dir-hint-module-name))))
(%search-load-path (in-vicinity dir-hint name))))
(define (loaded-modules)
;; Return list of all loaded modules sorted by name.
(sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
(lambda (m1 m2)
(symlist<? (module-name m1) (module-name m2)))))
(define (symlist<? l1 l2)
;; Return #t if symbol list L1 is alphabetically less than L2.
(cond ((null? l1) #t)
((null? l2) #f)
((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
(else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
;;;; {Source Breakpoint Installation}
(define (install-breakpoints x bpinfo) (define (install-breakpoints x bpinfo)
(define (install-recursive x) (define (install-recursive x)
(if (list? x) (if (list? x)
@ -427,7 +529,95 @@ decimal IP address where the UI server is running; default is
(for-each install-recursive x)))) (for-each install-recursive x))))
(install-recursive x)) (install-recursive x))
(define (gds-eval x bpinfo m)
;;;; {Evaluation}
;; Evaluation threads are unleashed by two possible triggers. One is
;; a boolean variable, specific to each thread, that tells the thread
;; to exit when set to #t. The other is another boolean variable, but
;; global, indicating that there is an evaluation to perform:
(define eval-work-available #f)
;; This variable, which is only valid when `eval-work-available' is
;; #t, holds the evaluation to perform:
(define eval-work #f)
;; A mutex protects against concurrent access to these variables.
(define eval-work-mutex (make-mutex))
;; Changes in these variables are signaled by broadcasting the
;; following condition variable.
(define eval-work-changed (make-condition-variable))
;; When an evaluation thread takes some work, it tells the main GDS
;; thread by signaling this condition variable.
(define eval-work-taken (make-condition-variable))
(define-macro (without-mutex m . body)
`(dynamic-wind
(lambda () (unlock-mutex ,m))
(lambda () (begin ,@body))
(lambda () (lock-mutex ,m))))
(define next-thread-number
(let ((count 0))
(lambda ()
(set! count (+ count 1))
count)))
(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)))
(trc 'eval-thread depth thread-number "entering loop")
(let loop ()
(cond ((thread-should-exit-thunk)
;; Allow thread to exit.
)
(eval-work-available
;; 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))
(set! eval-work-available #f)
(signal-condition-variable eval-work-taken)
(without-mutex eval-work-mutex
;; Before starting evaluation, create another eval
;; thread like this one, so that it can take over
;; if another evaluation is requested before this
;; one is finished.
(make-thread eval-thread (+ depth 1)
(lambda () (not subthread-needed?)))
;; Do the evaluation(s).
(let loop2 ((correlator (car work))
(m (cadr work))
(exprs (cddr work))
(results '()))
(if (null? exprs)
(write-form `(eval-results ,correlator ,@results))
(loop2 correlator
m
(cdr exprs)
(append results (gds-eval (car exprs) m))))))
(trc 'eval-thread depth thread-number "work done")
;; Tell the subthread that it should now exit.
(set! subthread-needed? #f)
(broadcast-condition-variable eval-work-changed)
;; Loop for more work for this thread.
(loop)))
(else
;; Wait for something to change, then loop to check
;; trigger variables again.
(trc 'eval-thread depth thread-number "wait")
(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"))))
(define (gds-eval x m)
;; Consumer to accept possibly multiple values and present them for ;; Consumer to accept possibly multiple values and present them for
;; Emacs as a list of strings. ;; Emacs as a list of strings.
(define (value-consumer . values) (define (value-consumer . values)
@ -436,9 +626,6 @@ decimal IP address where the UI server is running; default is
(map (lambda (value) (map (lambda (value)
(with-output-to-string (lambda () (write value)))) (with-output-to-string (lambda () (write value))))
values))) values)))
;; Before evaluation, set breakpoints in the read code as specified
;; by bpinfo.
(install-breakpoints x bpinfo)
;; Now do evaluation. ;; Now do evaluation.
(let ((value #f)) (let ((value #f))
(let* ((do-eval (if m (let* ((do-eval (if m
@ -480,35 +667,5 @@ decimal IP address where the UI server is running; default is
'("unhandled-exception-in-evaluation")))))))))) '("unhandled-exception-in-evaluation"))))))))))
(list output value)))) (list output value))))
(define (write-status status)
(write-form (list 'current-module
(format #f "~S" (module-name (current-module)))))
(write-form (list 'status status)))
(define (loaded-module-source module-name)
;; Return the file name that (ice-9 boot-9) probably loaded the
;; named module from. (The `probably' is because `%load-path' might
;; have changed since the module was loaded.)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
(string-append (symbol->string elt) "/"))
dir-hint-module-name))))
(%search-load-path (in-vicinity dir-hint name))))
(define (loaded-modules)
;; Return list of all loaded modules sorted by name.
(sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
(lambda (m1 m2)
(symlist<? (module-name m1) (module-name m2)))))
(define (symlist<? l1 l2)
;; Return #t if symbol list L1 is alphabetically less than L2.
(cond ((null? l1) #t)
((null? l2) #f)
((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
(else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
;;; (emacs gds-client) ends here. ;;; (emacs gds-client) ends here.