module/ice-9/gds-client.scm

   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
 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.
 332 Thanks!\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.