1 (define-module (ice-9 gds-client)
2 #:use-module (oop goops)
3 #:use-module (oop goops describe)
4 #:use-module (ice-9 debugging trace)
5 #:use-module (ice-9 debugging traps)
6 #:use-module (ice-9 debugging trc)
7 #:use-module (ice-9 debugging steps)
8 #:use-module (ice-9 pretty-print)
9 #:use-module (ice-9 regex)
10 #:use-module (ice-9 session)
11 #:use-module (ice-9 string-fun)
12 #:export (gds-debug-trap
16 (cond ((string>=? (version) "1.7")
17 (use-modules (ice-9 debugger utils)))
19 (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
20 (module-export! the-ice-9-debugger-module
22 write-frame-short/application
23 write-frame-short/expression
27 (use-modules (ice-9 debugger))
31 ;; Return an integer that somehow identifies the current thread.
32 (define (get-thread-id)
33 (let ((root (dynamic-root)))
34 (cond ((integer? root)
37 (object-address root))
39 (error "Unexpected dynamic root:" root)))))
41 ;; gds-debug-read is a high-priority read. The (debug-thread-id ID)
42 ;; form causes the frontend to dismiss any reads from threads whose id
43 ;; is not ID, until it receives the (thread-id ...) form with the same
44 ;; id as ID. Dismissing the reads of any other threads (by sending a
45 ;; form that is otherwise ignored) causes those threads to release the
46 ;; read mutex, which allows the (gds-read) here to proceed.
47 (define (gds-debug-read)
48 (write-form `(debug-thread-id ,(get-thread-id)))
51 (define (gds-debug-trap trap-context)
52 "Invoke the GDS debugger to explore the stack at the specified trap."
54 (start-stack 'debugger
55 (let* ((stack (tc:stack trap-context))
56 (flags1 (let ((trap-type (tc:type trap-context)))
60 (tc:return-value trap-context)))
63 (flags (if (tc:continuation trap-context)
64 (cons #:continuable flags1)
66 (fired-traps (tc:fired-traps trap-context))
67 (special-index (and (= (length fired-traps) 1)
68 (is-a? (car fired-traps) <exit-trap>)
69 (eq? (tc:type trap-context) #:return)
70 (- (tc:depth trap-context)
71 (slot-ref (car fired-traps) 'depth)))))
72 ;; Write current stack to the frontend.
73 (write-form (list 'stack
74 (if (and special-index (> special-index 0))
77 (stack->emacs-readable stack)
78 (append (flags->emacs-readable flags)
79 (slot-ref trap-context
80 'handler-return-syms))))
81 ;; Now wait for instruction.
82 (let loop ((protocol (gds-debug-read)))
86 ;; Request to tweak the handler return value.
87 (let ((tweaking (catch #t
89 (list (with-input-from-string
92 (lambda ignored #f))))
94 (slot-set! trap-context
96 (cons 'instead (car tweaking)))))
97 (loop (gds-debug-read)))
99 ;; Continue (by exiting the debugger).
102 ;; Evaluate expression in specified frame.
103 (eval-in-frame stack (cadr protocol) (caddr protocol))
104 (loop (gds-debug-read)))
106 ;; Return frame info.
107 (let ((frame (stack-ref stack (cadr protocol))))
108 (write-form (list 'info-result
109 (with-output-to-string
111 (write-frame-long frame))))))
112 (loop (gds-debug-read)))
114 ;; Return frame args.
115 (let ((frame (stack-ref stack (cadr protocol))))
116 (write-form (list 'info-result
117 (with-output-to-string
119 (write-frame-args-long frame))))))
120 (loop (gds-debug-read)))
122 ;; Show source of application procedure.
123 (let* ((frame (stack-ref stack (cadr protocol)))
124 (proc (frame-procedure frame))
125 (source (and proc (procedure-source proc))))
126 (write-form (list 'info-result
128 (sans-surrounding-whitespace
129 (with-output-to-string
131 (pretty-print source))))
133 "This procedure is coded in C"
134 "This frame has no procedure")))))
135 (loop (gds-debug-read)))
137 ;; Show the traps that fired here.
138 (write-form (list 'info-result
139 (with-output-to-string
142 (tc:fired-traps trap-context))))))
143 (loop (gds-debug-read)))
145 ;; Set temporary breakpoint on next trap.
146 (at-step gds-debug-trap
149 (if (memq #:return flags)
151 (- (stack-length stack)
154 ;; Set temporary breakpoint on exit from
156 (at-exit (- (stack-length stack) (cadr protocol))
159 ;; Set temporary breakpoint on next trap in same
161 (at-step gds-debug-trap
163 (frame-file-name (stack-ref stack
165 (if (memq #:return flags)
167 (- (stack-length stack)
170 (safely-handle-nondebug-protocol protocol)
171 (loop (gds-debug-read))))))))
173 (define (connect-to-gds . application-name)
177 (or (let ((s (socket PF_INET SOCK_STREAM 0))
180 (setsockopt s SOL_TCP TCP_NODELAY 1)
183 (connect s AF_INET (inet-aton "127.0.0.1") 8333)
186 (let ((s (socket PF_UNIX SOCK_STREAM 0)))
189 (connect s AF_UNIX "/tmp/.gds_socket")
192 (error "Couldn't connect to GDS by TCP or Unix domain socket")))
193 (write-form (list 'name (getpid) (apply client-name application-name))))))
195 (define (client-name . application-name)
196 (let loop ((args (append application-name (program-arguments))))
198 (format #f "PID ~A" (getpid))
199 (let ((arg (car args)))
200 (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
202 ((string-match "^-" arg)
205 (format #f "~A (PID ~A)" arg (getpid))))))))
207 (if (not (defined? 'make-mutex))
209 (define (make-mutex) #f)
210 (define lock-mutex noop)
211 (define unlock-mutex noop)))
213 (define write-mutex (make-mutex))
215 (define (write-form form)
216 ;; Write any form FORM to GDS.
217 (lock-mutex write-mutex)
218 (write form gds-port)
220 (force-output gds-port)
221 (unlock-mutex write-mutex))
223 (define (stack->emacs-readable stack)
224 ;; Return Emacs-readable representation of STACK.
226 (frame->emacs-readable (stack-ref stack index)))
227 (iota (min (stack-length stack)
228 (cadr (memq 'depth (debug-options)))))))
230 (define (frame->emacs-readable frame)
231 ;; Return Emacs-readable representation of FRAME.
232 (if (frame-procedure? frame)
234 (with-output-to-string
236 (display (if (frame-real? frame) " " "t "))
237 (write-frame-short/application frame)))
238 (source->emacs-readable frame))
240 (with-output-to-string
242 (display (if (frame-real? frame) " " "t "))
243 (write-frame-short/expression frame)))
244 (source->emacs-readable frame))))
246 (define (source->emacs-readable frame)
247 ;; Return Emacs-readable representation of the filename, line and
248 ;; column source properties of SOURCE.
249 (or (frame->source-position frame) 'nil))
251 (define (flags->emacs-readable flags)
252 ;; Return Emacs-readable representation of trap FLAGS.
255 (let ((erf (if (and (keyword? flag)
256 (not (eq? prev #:return)))
257 (keyword->symbol flag)
258 (format #f "~S" flag))))
263 (define (eval-in-frame stack index expr)
269 (local-eval (with-input-from-string expr read)
270 (memoized-environment
271 (frame-source (stack-ref stack
274 (cons 'ERROR args)))))))
276 (set! (behaviour-ordering gds-debug-trap) 100)
278 ;;; Code below here adds support for interaction between the GDS
279 ;;; client program and the Emacs frontend even when not stopped in the
282 ;; A mutex to control attempts by multiple threads to read protocol
283 ;; back from the frontend.
284 (define gds-read-mutex (make-mutex))
286 ;; Read a protocol instruction from the frontend.
288 ;; Acquire the read mutex.
289 (lock-mutex gds-read-mutex)
290 ;; Tell the front end something that identifies us as a thread.
291 (write-form `(thread-id ,(get-thread-id)))
292 ;; Now read, then release the mutex and return what was read.
294 (lambda () (read gds-port))
295 (lambda ignored the-eof-object))))
296 (unlock-mutex gds-read-mutex)
299 (define (gds-accept-input exit-on-continue)
300 ;; If reading from the GDS connection returns EOF, we will throw to
304 (let loop ((protocol (gds-read)))
305 (if (or (eof-object? protocol)
306 (and exit-on-continue
307 (eq? (car protocol) 'continue)))
309 (safely-handle-nondebug-protocol protocol)
311 (lambda ignored #f)))
313 (define (safely-handle-nondebug-protocol protocol)
314 ;; This catch covers any internal errors in the GDS code or
320 (handle-nondebug-protocol protocol))
321 save-lazy-trap-context-and-rethrow))
324 `(eval-results (error . ,(format #f "~s" protocol))
325 ,(if last-lazy-trap-context 't 'nil)
327 Please report this to <neil@ossau.uklinux.net>, ideally including:
328 - a description of the scenario in which this error occurred
329 - which versions of Guile and guile-debugging you are using
330 - the error stack, which you can get by clicking on the link below,
331 and then cut and paste into your report.
333 ,(list (with-output-to-string
340 ;; The key that is used to signal a read error changes from 1.6 to
341 ;; 1.8; here we cover all eventualities by discovering the key
343 (define read-error-key
346 (with-input-from-string "(+ 3 4" read))
350 (define (handle-nondebug-protocol protocol)
354 (set! last-lazy-trap-context #f)
355 (apply (lambda (correlator module port-name line column code flags)
356 (with-input-from-string code
358 (set-port-filename! (current-input-port) port-name)
359 (set-port-line! (current-input-port) line)
360 (set-port-column! (current-input-port) column)
361 (let ((m (and module (resolve-module-from-root module))))
362 (catch read-error-key
364 (let loop ((exprs '()) (x (read)))
366 ;; Expressions to be evaluated have all
367 ;; been read. Now evaluate them.
368 (let loop2 ((exprs (reverse! exprs))
372 (write-form `(eval-results ,correlator
373 ,(if last-lazy-trap-context 't 'nil)
376 (append results (gds-eval (car exprs) m
377 (if (and (null? (cdr exprs))
381 ;; Another complete expression read; add
386 (install-trap (make <source-trap>
388 #:behaviour gds-debug-trap)))
389 (loop (cons x exprs) (read))))))
391 (write-form `(eval-results
393 ,(if last-lazy-trap-context 't 'nil)
394 ,(with-output-to-string
396 (display ";;; Reading expressions")
397 (display " to evaluate\n")
398 (apply display-error #f
399 (current-output-port) args)))
400 ("error-in-read")))))))))
404 (let ((matches (apropos-internal
405 (string-append "^" (regexp-quote (cadr protocol))))))
406 (cond ((null? matches)
407 (write-form '(completion-result nil)))
409 ;;(write matches (current-error-port))
410 ;;(newline (current-error-port))
412 (let loop ((match (symbol->string (car matches)))
413 (matches (cdr matches)))
414 ;;(write match (current-error-port))
415 ;;(newline (current-error-port))
416 ;;(write matches (current-error-port))
417 ;;(newline (current-error-port))
420 (if (string-prefix=? match
421 (symbol->string (car matches)))
422 (loop match (cdr matches))
423 (loop (substring match 0
424 (- (string-length match) 1))
426 (if (string=? match (cadr protocol))
427 (write-form `(completion-result
428 ,(map symbol->string matches)))
429 (write-form `(completion-result
432 ((debug-lazy-trap-context)
433 (if last-lazy-trap-context
434 (gds-debug-trap last-lazy-trap-context)
435 (error "There is no stack available to show")))
438 (error "Unexpected protocol:" protocol))))
440 (define (resolve-module-from-root name)
441 (save-module-excursion
443 (set-current-module the-root-module)
444 (resolve-module name))))
446 (define (gds-eval x m part)
447 ;; Consumer to accept possibly multiple values and present them for
448 ;; Emacs as a list of strings.
449 (define (value-consumer . values)
450 (if (unspecified? (car values))
453 (with-output-to-string (lambda () (write value))))
455 ;; Now do evaluation.
456 (let ((intro (if part
457 (format #f ";;; Evaluating expression ~A" part)
460 (let* ((do-eval (if m
463 (display " in module ")
464 (write (module-name m))
467 (call-with-values (lambda ()
468 (start-stack 'gds-eval-stack
473 (display " in current module ")
474 (write (module-name (current-module)))
477 (call-with-values (lambda ()
478 (start-stack 'gds-eval-stack
482 (with-output-to-string
488 save-lazy-trap-context-and-rethrow))
491 ((misc-error signal unbound-variable numerical-overflow)
492 (apply display-error #f
493 (current-output-port) args)
494 (set! value '("error-in-evaluation")))
496 (display "EXCEPTION: ")
502 '("unhandled-exception-in-evaluation"))))))))))
503 (list output value))))
505 (define last-lazy-trap-context #f)
507 (define (save-lazy-trap-context-and-rethrow key . args)
508 (set! last-lazy-trap-context
509 (throw->trap-context key args save-lazy-trap-context-and-rethrow))
510 (apply throw key args))
512 (define (run-utility)
517 (named-module-use! '(guile-user) '(ice-9 session))
518 (gds-accept-input #f))
520 (define-method (trap-description (trap <trap>))
521 (let loop ((description (list (class-name (class-of trap))))
525 (loop (if (slot-ref trap 'installed)
526 (cons 'installed description)
530 (loop (if (slot-ref trap 'condition)
531 (cons 'conditional description)
535 (loop (let ((skip-count (slot-ref trap 'skip-count)))
536 (if (zero? skip-count)
538 (cons* skip-count 'skip-count description)))
541 (loop (if (slot-ref trap 'single-shot)
542 (cons 'single-shot description)
546 (reverse! description)))))
548 (define-method (trap-description (trap <procedure-trap>))
549 (let ((description (next-method)))
550 (set-cdr! description
551 (cons (procedure-name (slot-ref trap 'procedure))
555 (define-method (trap-description (trap <source-trap>))
556 (let ((description (next-method)))
557 (set-cdr! description
558 (cons (format #f "~s" (slot-ref trap 'expression))
562 (define-method (trap-description (trap <location-trap>))
563 (let ((description (next-method)))
564 (set-cdr! description
565 (cons* (slot-ref trap 'file-regexp)
566 (slot-ref trap 'line)
567 (slot-ref trap 'column)
571 (define (gds-trace-trap trap-context)
573 (gds-do-trace trap-context)
574 (at-exit (tc:depth trap-context) gds-do-trace))
576 (define (gds-do-trace trap-context)
577 (write-form (list 'trace
580 (trace/stack-real-depth trap-context)
581 (trace/info trap-context)))))
583 (define (gds-trace-subtree trap-context)
585 (gds-do-trace trap-context)
586 (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
587 (install-trap step-trap)
588 (at-exit (tc:depth trap-context)
589 (lambda (trap-context)
590 (uninstall-trap step-trap)))))
592 ;;; (ice-9 gds-client) ends here.