lambda* in make-mutable-parameter

[bpt/guile.git] / module / ice-9 / gds-client.scm

(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)
  (named-module-use! '(guile-user) '(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.