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 13 run-utility 14 gds-accept-input)) 15 16(cond ((string>=? (version) "1.7") 17 (use-modules (ice-9 debugger utils))) 18 (else 19 (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger))) 20 (module-export! the-ice-9-debugger-module 21 '(source-position 22 write-frame-short/application 23 write-frame-short/expression 24 write-frame-args-long 25 write-frame-long)))) 26 27(use-modules (ice-9 debugger)) 28 29(define gds-port #f) 30 31;; Return an integer that somehow identifies the current thread. 32(define (get-thread-id) 33 (let ((root (dynamic-root))) 34 (cond ((integer? root) 35 root) 36 ((pair? root) 37 (object-address root)) 38 (else 39 (error "Unexpected dynamic root:" root))))) 40 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))) 49 (gds-read)) 50 51(define (gds-debug-trap trap-context) 52 "Invoke the GDS debugger to explore the stack at the specified trap." 53 (connect-to-gds) 54 (start-stack 'debugger 55 (let* ((stack (tc:stack trap-context)) 56 (flags1 (let ((trap-type (tc:type trap-context))) 57 (case trap-type 58 ((#:return #:error) 59 (list trap-type 60 (tc:return-value trap-context))) 61 (else 62 (list trap-type))))) 63 (flags (if (tc:continuation trap-context) 64 (cons #:continuable flags1) 65 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)) 75 special-index 76 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))) 83 ;; Act on it. 84 (case (car protocol) 85 ((tweak) 86 ;; Request to tweak the handler return value. 87 (let ((tweaking (catch #t 88 (lambda () 89 (list (with-input-from-string 90 (cadr protocol) 91 read))) 92 (lambda ignored #f)))) 93 (if tweaking 94 (slot-set! trap-context 95 'handler-return-value 96 (cons 'instead (car tweaking))))) 97 (loop (gds-debug-read))) 98 ((continue) 99 ;; Continue (by exiting the debugger). 100 *unspecified*) 101 ((evaluate) 102 ;; Evaluate expression in specified frame. 103 (eval-in-frame stack (cadr protocol) (caddr protocol)) 104 (loop (gds-debug-read))) 105 ((info-frame) 106 ;; Return frame info. 107 (let ((frame (stack-ref stack (cadr protocol)))) 108 (write-form (list 'info-result 109 (with-output-to-string 110 (lambda () 111 (write-frame-long frame)))))) 112 (loop (gds-debug-read))) 113 ((info-args) 114 ;; Return frame args. 115 (let ((frame (stack-ref stack (cadr protocol)))) 116 (write-form (list 'info-result 117 (with-output-to-string 118 (lambda () 119 (write-frame-args-long frame)))))) 120 (loop (gds-debug-read))) 121 ((proc-source) 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 127 (if source 128 (sans-surrounding-whitespace 129 (with-output-to-string 130 (lambda () 131 (pretty-print source)))) 132 (if proc 133 "This procedure is coded in C" 134 "This frame has no procedure"))))) 135 (loop (gds-debug-read))) 136 ((traps-here) 137 ;; Show the traps that fired here. 138 (write-form (list 'info-result 139 (with-output-to-string 140 (lambda () 141 (for-each describe 142 (tc:fired-traps trap-context)))))) 143 (loop (gds-debug-read))) 144 ((step-into) 145 ;; Set temporary breakpoint on next trap. 146 (at-step gds-debug-trap 147 1 148 #f 149 (if (memq #:return flags) 150 #f 151 (- (stack-length stack) 152 (cadr protocol))))) 153 ((step-over) 154 ;; Set temporary breakpoint on exit from 155 ;; specified frame. 156 (at-exit (- (stack-length stack) (cadr protocol)) 157 gds-debug-trap)) 158 ((step-file) 159 ;; Set temporary breakpoint on next trap in same 160 ;; source file. 161 (at-step gds-debug-trap 162 1 163 (frame-file-name (stack-ref stack 164 (cadr protocol))) 165 (if (memq #:return flags) 166 #f 167 (- (stack-length stack) 168 (cadr protocol))))) 169 (else 170 (safely-handle-nondebug-protocol protocol) 171 (loop (gds-debug-read)))))))) 172 173(define (connect-to-gds . application-name) 174 (or gds-port 175 (begin 176 (set! gds-port 177 (or (let ((s (socket PF_INET SOCK_STREAM 0)) 178 (SOL_TCP 6) 179 (TCP_NODELAY 1)) 180 (setsockopt s SOL_TCP TCP_NODELAY 1) 181 (catch #t 182 (lambda () 183 (connect s AF_INET (inet-aton "127.0.0.1") 8333) 184 s) 185 (lambda _ #f))) 186 (let ((s (socket PF_UNIX SOCK_STREAM 0))) 187 (catch #t 188 (lambda () 189 (connect s AF_UNIX "/tmp/.gds_socket") 190 s) 191 (lambda _ #f))) 192 (error "Couldn't connect to GDS by TCP or Unix domain socket"))) 193 (write-form (list 'name (getpid) (apply client-name application-name)))))) 194 195(define (client-name . application-name) 196 (let loop ((args (append application-name (program-arguments)))) 197 (if (null? args) 198 (format #f "PID ~A" (getpid)) 199 (let ((arg (car args))) 200 (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg) 201 (loop (cdr args))) 202 ((string-match "^-" arg) 203 (loop (cdr args))) 204 (else 205 (format #f "~A (PID ~A)" arg (getpid)))))))) 206 207(if (not (defined? 'make-mutex)) 208 (begin 209 (define (make-mutex) #f) 210 (define lock-mutex noop) 211 (define unlock-mutex noop))) 212 213(define write-mutex (make-mutex)) 214 215(define (write-form form) 216 ;; Write any form FORM to GDS. 217 (lock-mutex write-mutex) 218 (write form gds-port) 219 (newline gds-port) 220 (force-output gds-port) 221 (unlock-mutex write-mutex)) 222 223(define (stack->emacs-readable stack) 224 ;; Return Emacs-readable representation of STACK. 225 (map (lambda (index) 226 (frame->emacs-readable (stack-ref stack index))) 227 (iota (min (stack-length stack) 228 (cadr (memq 'depth (debug-options))))))) 229 230(define (frame->emacs-readable frame) 231 ;; Return Emacs-readable representation of FRAME. 232 (if (frame-procedure? frame) 233 (list 'application 234 (with-output-to-string 235 (lambda () 236 (display (if (frame-real? frame) " " "t ")) 237 (write-frame-short/application frame))) 238 (source->emacs-readable frame)) 239 (list 'evaluation 240 (with-output-to-string 241 (lambda () 242 (display (if (frame-real? frame) " " "t ")) 243 (write-frame-short/expression frame))) 244 (source->emacs-readable frame)))) 245 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)) 250 251(define (flags->emacs-readable flags) 252 ;; Return Emacs-readable representation of trap FLAGS. 253 (let ((prev #f)) 254 (map (lambda (flag) 255 (let ((erf (if (and (keyword? flag) 256 (not (eq? prev #:return))) 257 (keyword->symbol flag) 258 (format #f "~S" flag)))) 259 (set! prev flag) 260 erf)) 261 flags))) 262 263(define (eval-in-frame stack index expr) 264 (write-form 265 (list 'eval-result 266 (format #f "~S" 267 (catch #t 268 (lambda () 269 (local-eval (with-input-from-string expr read) 270 (memoized-environment 271 (frame-source (stack-ref stack 272 index))))) 273 (lambda args 274 (cons 'ERROR args))))))) 275 276(set! (behaviour-ordering gds-debug-trap) 100) 277 278;;; Code below here adds support for interaction between the GDS 279;;; client program and the Emacs frontend even when not stopped in the 280;;; debugger. 281 282;; A mutex to control attempts by multiple threads to read protocol 283;; back from the frontend. 284(define gds-read-mutex (make-mutex)) 285 286;; Read a protocol instruction from the frontend. 287(define (gds-read) 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. 293 (let ((x (catch #t 294 (lambda () (read gds-port)) 295 (lambda ignored the-eof-object)))) 296 (unlock-mutex gds-read-mutex) 297 x)) 298 299(define (gds-accept-input exit-on-continue) 300 ;; If reading from the GDS connection returns EOF, we will throw to 301 ;; this catch. 302 (catch 'server-eof 303 (lambda () 304 (let loop ((protocol (gds-read))) 305 (if (or (eof-object? protocol) 306 (and exit-on-continue 307 (eq? (car protocol) 'continue))) 308 (throw 'server-eof)) 309 (safely-handle-nondebug-protocol protocol) 310 (loop (gds-read)))) 311 (lambda ignored #f))) 312 313(define (safely-handle-nondebug-protocol protocol) 314 ;; This catch covers any internal errors in the GDS code or 315 ;; protocol. 316 (catch #t 317 (lambda () 318 (lazy-catch #t 319 (lambda () 320 (handle-nondebug-protocol protocol)) 321 save-lazy-trap-context-and-rethrow)) 322 (lambda (key . args) 323 (write-form 324 `(eval-results (error . ,(format #f "~s" protocol)) 325 ,(if last-lazy-trap-context 't 'nil) 326 "GDS Internal Error 327Please 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. 332Thanks!\n\n" 333 ,(list (with-output-to-string 334 (lambda () 335 (write key) 336 (display ": ") 337 (write args) 338 (newline))))))))) 339 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 342;; dynamically. 343(define read-error-key 344 (catch #t 345 (lambda () 346 (with-input-from-string "(+ 3 4" read)) 347 (lambda (key . args) 348 key))) 349 350(define (handle-nondebug-protocol protocol) 351 (case (car protocol) 352 353 ((eval) 354 (set! last-lazy-trap-context #f) 355 (apply (lambda (correlator module port-name line column code flags) 356 (with-input-from-string code 357 (lambda () 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 363 (lambda () 364 (let loop ((exprs '()) (x (read))) 365 (if (eof-object? x) 366 ;; Expressions to be evaluated have all 367 ;; been read. Now evaluate them. 368 (let loop2 ((exprs (reverse! exprs)) 369 (results '()) 370 (n 1)) 371 (if (null? exprs) 372 (write-form `(eval-results ,correlator 373 ,(if last-lazy-trap-context 't 'nil) 374 ,@results)) 375 (loop2 (cdr exprs) 376 (append results (gds-eval (car exprs) m 377 (if (and (null? (cdr exprs)) 378 (= n 1)) 379 #f n))) 380 (+ n 1)))) 381 ;; Another complete expression read; add 382 ;; it to the list. 383 (begin 384 (if (and (pair? x) 385 (memq 'debug flags)) 386 (install-trap (make <source-trap> 387 #:expression x 388 #:behaviour gds-debug-trap))) 389 (loop (cons x exprs) (read)))))) 390 (lambda (key . args) 391 (write-form `(eval-results 392 ,correlator 393 ,(if last-lazy-trap-context 't 'nil) 394 ,(with-output-to-string 395 (lambda () 396 (display ";;; Reading expressions") 397 (display " to evaluate\n") 398 (apply display-error #f 399 (current-output-port) args))) 400 ("error-in-read"))))))))) 401 (cdr protocol))) 402 403 ((complete) 404 (let ((matches (apropos-internal 405 (string-append "^" (regexp-quote (cadr protocol)))))) 406 (cond ((null? matches) 407 (write-form '(completion-result nil))) 408 (else 409 ;;(write matches (current-error-port)) 410 ;;(newline (current-error-port)) 411 (let ((match 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)) 418 (if (null? matches) 419 match 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)) 425 matches)))))) 426 (if (string=? match (cadr protocol)) 427 (write-form `(completion-result 428 ,(map symbol->string matches))) 429 (write-form `(completion-result 430 ,match)))))))) 431 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"))) 436 437 (else 438 (error "Unexpected protocol:" protocol)))) 439 440(define (resolve-module-from-root name) 441 (save-module-excursion 442 (lambda () 443 (set-current-module the-root-module) 444 (resolve-module name)))) 445 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)) 451 '() 452 (map (lambda (value) 453 (with-output-to-string (lambda () (write value)))) 454 values))) 455 ;; Now do evaluation. 456 (let ((intro (if part 457 (format #f ";;; Evaluating expression ~A" part) 458 ";;; Evaluating")) 459 (value #f)) 460 (let* ((do-eval (if m 461 (lambda () 462 (display intro) 463 (display " in module ") 464 (write (module-name m)) 465 (newline) 466 (set! value 467 (call-with-values (lambda () 468 (start-stack 'gds-eval-stack 469 (eval x m))) 470 value-consumer))) 471 (lambda () 472 (display intro) 473 (display " in current module ") 474 (write (module-name (current-module))) 475 (newline) 476 (set! value 477 (call-with-values (lambda () 478 (start-stack 'gds-eval-stack 479 (primitive-eval x))) 480 value-consumer))))) 481 (output 482 (with-output-to-string 483 (lambda () 484 (catch #t 485 (lambda () 486 (lazy-catch #t 487 do-eval 488 save-lazy-trap-context-and-rethrow)) 489 (lambda (key . args) 490 (case key 491 ((misc-error signal unbound-variable numerical-overflow) 492 (apply display-error #f 493 (current-output-port) args) 494 (set! value '("error-in-evaluation"))) 495 (else 496 (display "EXCEPTION: ") 497 (display key) 498 (display " ") 499 (write args) 500 (newline) 501 (set! value 502 '("unhandled-exception-in-evaluation")))))))))) 503 (list output value)))) 504 505(define last-lazy-trap-context #f) 506 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)) 511 512(define (run-utility) 513 (connect-to-gds) 514 (write (getpid)) 515 (newline) 516 (force-output) 517 (named-module-use! '(guile-user) '(ice-9 session)) 518 (gds-accept-input #f)) 519 520(define-method (trap-description (trap <trap>)) 521 (let loop ((description (list (class-name (class-of trap)))) 522 (next 'installed?)) 523 (case next 524 ((installed?) 525 (loop (if (slot-ref trap 'installed) 526 (cons 'installed description) 527 description) 528 'conditional?)) 529 ((conditional?) 530 (loop (if (slot-ref trap 'condition) 531 (cons 'conditional description) 532 description) 533 'skip-count)) 534 ((skip-count) 535 (loop (let ((skip-count (slot-ref trap 'skip-count))) 536 (if (zero? skip-count) 537 description 538 (cons* skip-count 'skip-count description))) 539 'single-shot?)) 540 ((single-shot?) 541 (loop (if (slot-ref trap 'single-shot) 542 (cons 'single-shot description) 543 description) 544 'done)) 545 (else 546 (reverse! description))))) 547 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)) 552 (cdr description))) 553 description)) 554 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)) 559 (cdr description))) 560 description)) 561 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) 568 (cdr description))) 569 description)) 570 571(define (gds-trace-trap trap-context) 572 (connect-to-gds) 573 (gds-do-trace trap-context) 574 (at-exit (tc:depth trap-context) gds-do-trace)) 575 576(define (gds-do-trace trap-context) 577 (write-form (list 'trace 578 (format #f 579 "~3@a: ~a" 580 (trace/stack-real-depth trap-context) 581 (trace/info trap-context))))) 582 583(define (gds-trace-subtree trap-context) 584 (connect-to-gds) 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))))) 591 592;;; (ice-9 gds-client) ends here. 593