diff options
Diffstat (limited to 'module/ice-9')
| -rwxr-xr-x | module/ice-9/gds-client.scm | 583 | ||||
| -rw-r--r-- | module/ice-9/gds-server.scm | 188 |
2 files changed, 0 insertions, 771 deletions
diff --git a/module/ice-9/gds-client.scm b/module/ice-9/gds-client.scm deleted file mode 100755 index 848b77485..000000000 --- a/module/ice-9/gds-client.scm +++ /dev/null @@ -1,583 +0,0 @@ -(define-module (ice-9 gds-client) - #:use-module (oop goops) - #:use-module (oop goops describe) - #:use-module (ice-9 debugging trace) - #:use-module (ice-9 debugging traps) - #:use-module (ice-9 debugging trc) - #:use-module (ice-9 debugging steps) - #:use-module (ice-9 pretty-print) - #:use-module (ice-9 regex) - #:use-module (ice-9 session) - #:use-module (ice-9 string-fun) - #:export (gds-debug-trap - run-utility - gds-accept-input)) - -(use-modules (ice-9 debugger utils)) - -(use-modules (ice-9 debugger)) - -(define gds-port #f) - -;; Return an integer that somehow identifies the current thread. -(define (get-thread-id) - (let ((root (dynamic-root))) - (cond ((integer? root) - root) - ((pair? root) - (object-address root)) - (else - (error "Unexpected dynamic root:" root))))) - -;; gds-debug-read is a high-priority read. The (debug-thread-id ID) -;; form causes the frontend to dismiss any reads from threads whose id -;; is not ID, until it receives the (thread-id ...) form with the same -;; id as ID. Dismissing the reads of any other threads (by sending a -;; form that is otherwise ignored) causes those threads to release the -;; read mutex, which allows the (gds-read) here to proceed. -(define (gds-debug-read) - (write-form `(debug-thread-id ,(get-thread-id))) - (gds-read)) - -(define (gds-debug-trap trap-context) - "Invoke the GDS debugger to explore the stack at the specified trap." - (connect-to-gds) - (start-stack 'debugger - (let* ((stack (tc:stack trap-context)) - (flags1 (let ((trap-type (tc:type trap-context))) - (case trap-type - ((#:return #:error) - (list trap-type - (tc:return-value trap-context))) - (else - (list trap-type))))) - (flags (if (tc:continuation trap-context) - (cons #:continuable flags1) - flags1)) - (fired-traps (tc:fired-traps trap-context)) - (special-index (and (= (length fired-traps) 1) - (is-a? (car fired-traps) <exit-trap>) - (eq? (tc:type trap-context) #:return) - (- (tc:depth trap-context) - (slot-ref (car fired-traps) 'depth))))) - ;; Write current stack to the frontend. - (write-form (list 'stack - (if (and special-index (> special-index 0)) - special-index - 0) - (stack->emacs-readable stack) - (append (flags->emacs-readable flags) - (slot-ref trap-context - 'handler-return-syms)))) - ;; Now wait for instruction. - (let loop ((protocol (gds-debug-read))) - ;; Act on it. - (case (car protocol) - ((tweak) - ;; Request to tweak the handler return value. - (let ((tweaking (catch #t - (lambda () - (list (with-input-from-string - (cadr protocol) - read))) - (lambda ignored #f)))) - (if tweaking - (slot-set! trap-context - 'handler-return-value - (cons 'instead (car tweaking))))) - (loop (gds-debug-read))) - ((continue) - ;; Continue (by exiting the debugger). - *unspecified*) - ((evaluate) - ;; Evaluate expression in specified frame. - (eval-in-frame stack (cadr protocol) (caddr protocol)) - (loop (gds-debug-read))) - ((info-frame) - ;; Return frame info. - (let ((frame (stack-ref stack (cadr protocol)))) - (write-form (list 'info-result - (with-output-to-string - (lambda () - (write-frame-long frame)))))) - (loop (gds-debug-read))) - ((info-args) - ;; Return frame args. - (let ((frame (stack-ref stack (cadr protocol)))) - (write-form (list 'info-result - (with-output-to-string - (lambda () - (write-frame-args-long frame)))))) - (loop (gds-debug-read))) - ((proc-source) - ;; Show source of application procedure. - (let* ((frame (stack-ref stack (cadr protocol))) - (proc (frame-procedure frame)) - (source (and proc (procedure-source proc)))) - (write-form (list 'info-result - (if source - (sans-surrounding-whitespace - (with-output-to-string - (lambda () - (pretty-print source)))) - (if proc - "This procedure is coded in C" - "This frame has no procedure"))))) - (loop (gds-debug-read))) - ((traps-here) - ;; Show the traps that fired here. - (write-form (list 'info-result - (with-output-to-string - (lambda () - (for-each describe - (tc:fired-traps trap-context)))))) - (loop (gds-debug-read))) - ((step-into) - ;; Set temporary breakpoint on next trap. - (at-step gds-debug-trap - 1 - #f - (if (memq #:return flags) - #f - (- (stack-length stack) - (cadr protocol))))) - ((step-over) - ;; Set temporary breakpoint on exit from - ;; specified frame. - (at-exit (- (stack-length stack) (cadr protocol)) - gds-debug-trap)) - ((step-file) - ;; Set temporary breakpoint on next trap in same - ;; source file. - (at-step gds-debug-trap - 1 - (frame-file-name (stack-ref stack - (cadr protocol))) - (if (memq #:return flags) - #f - (- (stack-length stack) - (cadr protocol))))) - (else - (safely-handle-nondebug-protocol protocol) - (loop (gds-debug-read)))))))) - -(define (connect-to-gds . application-name) - (or gds-port - (let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME"))) - (set! gds-port - (or (and gds-unix-socket-name - (false-if-exception - (let ((s (socket PF_UNIX SOCK_STREAM 0))) - (connect s AF_UNIX gds-unix-socket-name) - s))) - (false-if-exception - (let ((s (socket PF_INET SOCK_STREAM 0)) - (SOL_TCP 6) - (TCP_NODELAY 1)) - (setsockopt s SOL_TCP TCP_NODELAY 1) - (connect s AF_INET (inet-aton "127.0.0.1") 8333) - s)) - (error "Couldn't connect to GDS by TCP or Unix domain socket"))) - (write-form (list 'name (getpid) (apply client-name application-name)))))) - -(define (client-name . application-name) - (let loop ((args (append application-name (program-arguments)))) - (if (null? args) - (format #f "PID ~A" (getpid)) - (let ((arg (car args))) - (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg) - (loop (cdr args))) - ((string-match "^-" arg) - (loop (cdr args))) - (else - (format #f "~A (PID ~A)" arg (getpid)))))))) - -;;(if (not (defined? 'make-mutex)) -;; (begin -;; (define (make-mutex) #f) -;; (define lock-mutex noop) -;; (define unlock-mutex noop))) - -(define write-mutex (make-mutex)) - -(define (write-form form) - ;; Write any form FORM to GDS. - (lock-mutex write-mutex) - (write form gds-port) - (newline gds-port) - (force-output gds-port) - (unlock-mutex write-mutex)) - -(define (stack->emacs-readable stack) - ;; Return Emacs-readable representation of STACK. - (map (lambda (index) - (frame->emacs-readable (stack-ref stack index))) - (iota (min (stack-length stack) - (cadr (memq 'depth (debug-options))))))) - -(define (frame->emacs-readable frame) - ;; Return Emacs-readable representation of FRAME. - (if (frame-procedure? frame) - (list 'application - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "t ")) - (write-frame-short/application frame))) - (source->emacs-readable frame)) - (list 'evaluation - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "t ")) - (write-frame-short/expression frame))) - (source->emacs-readable frame)))) - -(define (source->emacs-readable frame) - ;; Return Emacs-readable representation of the filename, line and - ;; column source properties of SOURCE. - (or (frame->source-position frame) 'nil)) - -(define (flags->emacs-readable flags) - ;; Return Emacs-readable representation of trap FLAGS. - (let ((prev #f)) - (map (lambda (flag) - (let ((erf (if (and (keyword? flag) - (not (eq? prev #:return))) - (keyword->symbol flag) - (format #f "~S" flag)))) - (set! prev flag) - erf)) - flags))) - -;; FIXME: the new evaluator breaks this, by removing local-eval. Need to -;; figure out our story in this regard. -(define (eval-in-frame stack index expr) - (write-form - (list 'eval-result - (format #f "~S" - (catch #t - (lambda () - (local-eval (with-input-from-string expr read) - (memoized-environment - (frame-source (stack-ref stack - index))))) - (lambda args - (cons 'ERROR args))))))) - -(set! (behaviour-ordering gds-debug-trap) 100) - -;;; Code below here adds support for interaction between the GDS -;;; client program and the Emacs frontend even when not stopped in the -;;; debugger. - -;; A mutex to control attempts by multiple threads to read protocol -;; back from the frontend. -(define gds-read-mutex (make-mutex)) - -;; Read a protocol instruction from the frontend. -(define (gds-read) - ;; Acquire the read mutex. - (lock-mutex gds-read-mutex) - ;; Tell the front end something that identifies us as a thread. - (write-form `(thread-id ,(get-thread-id))) - ;; Now read, then release the mutex and return what was read. - (let ((x (catch #t - (lambda () (read gds-port)) - (lambda ignored the-eof-object)))) - (unlock-mutex gds-read-mutex) - x)) - -(define (gds-accept-input exit-on-continue) - ;; If reading from the GDS connection returns EOF, we will throw to - ;; this catch. - (catch 'server-eof - (lambda () - (let loop ((protocol (gds-read))) - (if (or (eof-object? protocol) - (and exit-on-continue - (eq? (car protocol) 'continue))) - (throw 'server-eof)) - (safely-handle-nondebug-protocol protocol) - (loop (gds-read)))) - (lambda ignored #f))) - -(define (safely-handle-nondebug-protocol protocol) - ;; This catch covers any internal errors in the GDS code or - ;; protocol. - (catch #t - (lambda () - (lazy-catch #t - (lambda () - (handle-nondebug-protocol protocol)) - save-lazy-trap-context-and-rethrow)) - (lambda (key . args) - (write-form - `(eval-results (error . ,(format #f "~s" protocol)) - ,(if last-lazy-trap-context 't 'nil) - "GDS Internal Error -Please report this to <neil@ossau.uklinux.net>, ideally including: -- a description of the scenario in which this error occurred -- which versions of Guile and guile-debugging you are using -- the error stack, which you can get by clicking on the link below, - and then cut and paste into your report. -Thanks!\n\n" - ,(list (with-output-to-string - (lambda () - (write key) - (display ": ") - (write args) - (newline))))))))) - -;; The key that is used to signal a read error changes from 1.6 to -;; 1.8; here we cover all eventualities by discovering the key -;; dynamically. -(define read-error-key - (catch #t - (lambda () - (with-input-from-string "(+ 3 4" read)) - (lambda (key . args) - key))) - -(define (handle-nondebug-protocol protocol) - (case (car protocol) - - ((eval) - (set! last-lazy-trap-context #f) - (apply (lambda (correlator module port-name line column code flags) - (with-input-from-string code - (lambda () - (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-from-root module)))) - (catch read-error-key - (lambda () - (let loop ((exprs '()) (x (read))) - (if (eof-object? x) - ;; Expressions to be evaluated have all - ;; been read. Now evaluate them. - (let loop2 ((exprs (reverse! exprs)) - (results '()) - (n 1)) - (if (null? exprs) - (write-form `(eval-results ,correlator - ,(if last-lazy-trap-context 't 'nil) - ,@results)) - (loop2 (cdr exprs) - (append results (gds-eval (car exprs) m - (if (and (null? (cdr exprs)) - (= n 1)) - #f n))) - (+ n 1)))) - ;; Another complete expression read; add - ;; it to the list. - (begin - (if (and (pair? x) - (memq 'debug flags)) - (install-trap (make <source-trap> - #:expression x - #:behaviour gds-debug-trap))) - (loop (cons x exprs) (read)))))) - (lambda (key . args) - (write-form `(eval-results - ,correlator - ,(if last-lazy-trap-context 't 'nil) - ,(with-output-to-string - (lambda () - (display ";;; Reading expressions") - (display " to evaluate\n") - (apply display-error #f - (current-output-port) args))) - ("error-in-read"))))))))) - (cdr protocol))) - - ((complete) - (let ((matches (apropos-internal - (string-append "^" (regexp-quote (cadr protocol)))))) - (cond ((null? matches) - (write-form '(completion-result nil))) - (else - ;;(write matches (current-error-port)) - ;;(newline (current-error-port)) - (let ((match - (let loop ((match (symbol->string (car matches))) - (matches (cdr matches))) - ;;(write match (current-error-port)) - ;;(newline (current-error-port)) - ;;(write matches (current-error-port)) - ;;(newline (current-error-port)) - (if (null? matches) - match - (if (string-prefix=? match - (symbol->string (car matches))) - (loop match (cdr matches)) - (loop (substring match 0 - (- (string-length match) 1)) - matches)))))) - (if (string=? match (cadr protocol)) - (write-form `(completion-result - ,(map symbol->string matches))) - (write-form `(completion-result - ,match)))))))) - - ((debug-lazy-trap-context) - (if last-lazy-trap-context - (gds-debug-trap last-lazy-trap-context) - (error "There is no stack available to show"))) - - (else - (error "Unexpected protocol:" protocol)))) - -(define (resolve-module-from-root name) - (save-module-excursion - (lambda () - (set-current-module the-root-module) - (resolve-module name)))) - -(define (gds-eval x m part) - ;; Consumer to accept possibly multiple values and present them for - ;; Emacs as a list of strings. - (define (value-consumer . values) - (if (unspecified? (car values)) - '() - (map (lambda (value) - (with-output-to-string (lambda () (write value)))) - values))) - ;; Now do evaluation. - (let ((intro (if part - (format #f ";;; Evaluating expression ~A" part) - ";;; Evaluating")) - (value #f)) - (let* ((do-eval (if m - (lambda () - (display intro) - (display " in module ") - (write (module-name m)) - (newline) - (set! value - (call-with-values (lambda () - (start-stack 'gds-eval-stack - (eval x m))) - value-consumer))) - (lambda () - (display intro) - (display " in current module ") - (write (module-name (current-module))) - (newline) - (set! value - (call-with-values (lambda () - (start-stack 'gds-eval-stack - (primitive-eval x))) - value-consumer))))) - (output - (with-output-to-string - (lambda () - (catch #t - (lambda () - (lazy-catch #t - do-eval - save-lazy-trap-context-and-rethrow)) - (lambda (key . args) - (case key - ((misc-error signal unbound-variable numerical-overflow) - (apply display-error #f - (current-output-port) args) - (set! value '("error-in-evaluation"))) - (else - (display "EXCEPTION: ") - (display key) - (display " ") - (write args) - (newline) - (set! value - '("unhandled-exception-in-evaluation")))))))))) - (list output value)))) - -(define last-lazy-trap-context #f) - -(define (save-lazy-trap-context-and-rethrow key . args) - (set! last-lazy-trap-context - (throw->trap-context key args save-lazy-trap-context-and-rethrow)) - (apply throw key args)) - -(define (run-utility) - (connect-to-gds) - (write (getpid)) - (newline) - (force-output) - (module-use! (resolve-module '(guile-user)) - (resolve-interface '(ice-9 session))) - (gds-accept-input #f)) - -(define-method (trap-description (trap <trap>)) - (let loop ((description (list (class-name (class-of trap)))) - (next 'installed?)) - (case next - ((installed?) - (loop (if (slot-ref trap 'installed) - (cons 'installed description) - description) - 'conditional?)) - ((conditional?) - (loop (if (slot-ref trap 'condition) - (cons 'conditional description) - description) - 'skip-count)) - ((skip-count) - (loop (let ((skip-count (slot-ref trap 'skip-count))) - (if (zero? skip-count) - description - (cons* skip-count 'skip-count description))) - 'single-shot?)) - ((single-shot?) - (loop (if (slot-ref trap 'single-shot) - (cons 'single-shot description) - description) - 'done)) - (else - (reverse! description))))) - -(define-method (trap-description (trap <procedure-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons (procedure-name (slot-ref trap 'procedure)) - (cdr description))) - description)) - -(define-method (trap-description (trap <source-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons (format #f "~s" (slot-ref trap 'expression)) - (cdr description))) - description)) - -(define-method (trap-description (trap <location-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons* (slot-ref trap 'file-regexp) - (slot-ref trap 'line) - (slot-ref trap 'column) - (cdr description))) - description)) - -(define (gds-trace-trap trap-context) - (connect-to-gds) - (gds-do-trace trap-context) - (at-exit (tc:depth trap-context) gds-do-trace)) - -(define (gds-do-trace trap-context) - (write-form (list 'trace - (format #f - "~3@a: ~a" - (trace/stack-real-depth trap-context) - (trace/info trap-context))))) - -(define (gds-trace-subtree trap-context) - (connect-to-gds) - (gds-do-trace trap-context) - (let ((step-trap (make <step-trap> #:behaviour gds-do-trace))) - (install-trap step-trap) - (at-exit (tc:depth trap-context) - (lambda (trap-context) - (uninstall-trap step-trap))))) - -;;; (ice-9 gds-client) ends here. diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm deleted file mode 100644 index 5ec867535..000000000 --- a/module/ice-9/gds-server.scm +++ /dev/null @@ -1,188 +0,0 @@ -;;;; Guile Debugger UI server - -;;; Copyright (C) 2003 Free Software Foundation, Inc. -;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 gds-server) - #:export (run-server)) - -;; UI is normally via a pipe to Emacs, so make sure to flush output -;; every time we write. -(define (write-to-ui form) - (write form) - (newline) - (force-output)) - -(define (trc . args) - (write-to-ui (cons '* args))) - -(define (with-error->eof proc port) - (catch #t - (lambda () (proc port)) - (lambda args the-eof-object))) - -(define connection->id (make-object-property)) - -(define (run-server unix-socket-name tcp-port) - - (let ((unix-server (socket PF_UNIX SOCK_STREAM 0)) - (tcp-server (socket PF_INET SOCK_STREAM 0))) - - ;; Bind and start listening on the Unix domain socket. - (false-if-exception (delete-file unix-socket-name)) - (bind unix-server AF_UNIX unix-socket-name) - (listen unix-server 5) - - ;; Bind and start listening on the TCP socket. - (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1) - (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port)) - (listen tcp-server 5) - - ;; Main loop. - (let loop ((clients '()) (readable-sockets '())) - - (define (do-read port) - (cond ((eq? port (current-input-port)) - (do-read-from-ui)) - ((eq? port unix-server) - (accept-new-client unix-server)) - ((eq? port tcp-server) - (accept-new-client tcp-server)) - (else - (do-read-from-client port)))) - - (define (do-read-from-ui) - (trc "reading from ui") - (let* ((form (with-error->eof read (current-input-port))) - (client (assq-ref (map (lambda (port) - (cons (connection->id port) port)) - clients) - (car form)))) - (with-error->eof read-char (current-input-port)) - (if client - (begin - (write (cdr form) client) - (newline client)) - (trc "client not found"))) - clients) - - (define (accept-new-client server) - (let ((new-port (car (accept server)))) - ;; Read the client's ID. - (let ((name-form (read new-port))) - ;; Absorb the following newline character. - (read-char new-port) - ;; Check that we have a name form. - (or (eq? (car name-form) 'name) - (error "Invalid name form:" name-form)) - ;; Store an association from the connection to the ID. - (set! (connection->id new-port) (cadr name-form)) - ;; Pass the name form on to Emacs. - (write-to-ui (cons (connection->id new-port) name-form))) - ;; Add the new connection to the set that we select on. - (cons new-port clients))) - - (define (do-read-from-client port) - (trc "reading from client") - (let ((next-char (with-error->eof peek-char port))) - ;;(trc 'next-char next-char) - (cond ((eof-object? next-char) - (write-to-ui (list (connection->id port) 'closed)) - (close port) - (delq port clients)) - ((char=? next-char #\() - (write-to-ui (cons (connection->id port) - (with-error->eof read port))) - clients) - (else - (with-error->eof read-char port) - clients)))) - - ;;(trc 'clients clients) - ;;(trc 'readable-sockets readable-sockets) - - (if (null? readable-sockets) - (loop clients (car (select (cons* (current-input-port) - unix-server - tcp-server - clients) - '() - '()))) - (loop (do-read (car readable-sockets)) (cdr readable-sockets)))))) - -;; What happens if there are multiple copies of Emacs running on the -;; same machine, and they all try to start up the GDS server? They -;; can't all listen on the same TCP port, so the short answer is that -;; all of them except the first will get an EADDRINUSE error when -;; trying to bind. -;; -;; We want to be able to handle this scenario, though, so that Scheme -;; code can be evaluated, and help invoked, in any of those Emacsen. -;; So we introduce the idea of a "slave server". When a new GDS -;; server gets an EADDRINUSE bind error, the implication is that there -;; is already a GDS server running, so the new server instead connects -;; to the existing one (by issuing a connect to the GDS port number). -;; -;; Let's call the first server the "master", and the new one the -;; "slave". In principle the master can now proxy any GDS client -;; connections through to the slave, so long as there is sufficient -;; information in the protocol for it to decide when and how to do -;; this. -;; -;; The basic information and mechanism that we need for this is as -;; follows. -;; -;; - A unique ID for each Emacs; this can be each Emacs's PID. When a -;; slave server connects to the master, it announces itself by sending -;; the protocol (emacs ID). -;; -;; - A way for a client to indicate which Emacs it wants to use. At -;; the protocol level, this is an extra argument in the (name ...) -;; protocol. (The absence of this argument means "no preference". A -;; simplistic master server might then decide to use its own Emacs; a -;; cleverer one might monitor which Emacs appears to be most in use, -;; and use that one.) At the API level this can be an optional -;; argument to the `gds-connect' procedure, and the Emacs GDS code -;; would obviously set this argument when starting a client from -;; within Emacs. -;; -;; We also want a strategy for continuing seamlessly if the master -;; server shuts down. -;; -;; - Each slave server will detect this as an error on the connection -;; to the master socket. Each server then tries to bind to the GDS -;; port again (a race which the OS will resolve), and if that fails, -;; connect again. The result of this is that there should be a new -;; master, and the others all slaves connected to the new master. -;; -;; - Each client will also detect this as an error on the connection -;; to the (master) server. Either the client should try to connect -;; again (perhaps after a short delay), or the reconnection can be -;; delayed until the next time that the client requires the server. -;; (Probably the latter, all done within `gds-read'.) -;; -;; (Historical note: Before this master-slave idea, clients were -;; identified within gds-server.scm and gds*.el by an ID which was -;; actually the file descriptor of their connection to the server. -;; That is no good in the new scheme, because each client's ID must -;; persist when the master server changes, so we now use the client's -;; PID instead. We didn't use PID before because the client/server -;; code was written to be completely asynchronous, which made it -;; tricky for the server to discover each client's PID and associate -;; it with a particular connection. Now we solve that problem by -;; handling the initial protocol exchange synchronously.) -(define (run-slave-server port) - 'not-implemented) |