diff options
Diffstat (limited to 'module/ice-9/gds-client.scm')
| -rwxr-xr-x | module/ice-9/gds-client.scm | 583 |
1 files changed, 0 insertions, 583 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. |