guile-knots/knots.scm

(define-module (knots)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (rnrs bytevectors)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (fibers conditions)
  #:use-module (system repl debug)
  #:export (call-with-default-io-waiters

            wait-when-system-clock-behind

            call-with-sigint

            display/knots
            simple-format/knots
            format/knots

            &knots-exception
            make-knots-exception
            knots-exception?
            knots-exception-stack

            print-backtrace-and-exception/knots

            call-with-temporary-thread

            spawn-fiber/knots))

(define (call-with-default-io-waiters thunk)
  "Run THUNK with Guile's default blocking I/O waiters active.

This is useful when restoring the default Guile I/O waiters from
within a context (like Fibers) where different I/O waiters are used,
for example when creating a new thread from a fiber."
  (parameterize
      ((current-read-waiter (@@ (ice-9 suspendable-ports)
                                default-read-waiter))
       (current-write-waiter (@@ (ice-9 suspendable-ports)
                                 default-write-waiter)))
    (thunk)))

(define (wait-when-system-clock-behind)
  "Block until the system clock reads at least 2001-01-02.

Useful at startup in environments (virtual machines, embedded systems)
where the clock may start at or near the Unix epoch.  Prints a warning
to the current error port every 20 seconds while waiting."
  ;; Jan 02 2001 02:00:00
  (let ((start-of-the-year-2001 978400800))
    (while (< (current-time)
              start-of-the-year-2001)
      (simple-format (current-error-port)
                     "warning: system clock potentially behind, waiting\n")
      (sleep 20))))

;; Copied from (fibers web server)
(define (call-with-sigint thunk cvar)
  "Run THUNK with a SIGINT handler that signals the Fibers condition
CVAR.  Restores the previous handler when THUNK returns.

Typical usage is to pass a condition variable to this procedure and
wait on CVAR in a fiber to implement clean shutdown on Ctrl-C:

@example
(let ((quit-cvar (make-condition)))
  (call-with-sigint
    (lambda () (wait quit-cvar))
    quit-cvar))
@end example"
  (let ((handler #f))
    (dynamic-wind
      (lambda ()
        (set! handler
          (sigaction SIGINT (lambda (sig) (signal-condition! cvar)))))
      thunk
      (lambda ()
        (if handler
            ;; restore Scheme handler, SIG_IGN or SIG_DFL.
            (sigaction SIGINT (car handler) (cdr handler))
            ;; restore original C handler.
            (sigaction SIGINT #f))))))

(define (call-with-temporary-thread thunk)
  (let ((channel (make-channel)))
    (call-with-new-thread
     (lambda ()
       (call-with-default-io-waiters
        (lambda ()
         (with-exception-handler
             (lambda (exn)
               (put-message channel `(exception . ,exn)))
           (lambda ()
             (with-exception-handler
                 (lambda (exn)
                   (let ((stack
                          (match (fluid-ref %stacks)
                            ((stack-tag . prompt-tag)
                             (make-stack #t
                                         0 prompt-tag
                                         0 (and prompt-tag 1)))
                            (_
                             (make-stack #t)))))
                     (raise-exception
                      (make-exception
                       exn
                       (make-knots-exception stack)))))
               (lambda ()
                 (call-with-values thunk
                   (lambda values
                     (put-message channel `(values ,@values)))))))
           #:unwind? #t)))))

    (match (get-message channel)
      (('values . results)
       (apply values results))
      (('exception . exn)
       (raise-exception exn)))))

(define* (display/knots obj #:optional (port (current-output-port)))
  "Write OBJ to PORT (default: current output port) as a UTF-8 byte
sequence via @code{put-bytevector}.

When used with ports without buffering, this should be safer than
display."
  (put-bytevector
   port
   (string->utf8
    (call-with-output-string
      (lambda (port)
        (display obj port))))))

(define (simple-format/knots port s . args)
  "Like @code{simple-format} but should be safer when used with a port
without buffering."
  (let ((str (apply simple-format #f s args)))
    (if (eq? #f port)
        str
        (display/knots
         str
         (if (eq? #t port)
             (current-output-port)
             port)))))

(define (format/knots port s . args)
  "Like @code{format} but should be safer when used with a port
without buffering."
  (let ((str (apply format #f s args)))
    (if (eq? #f port)
        str
        (display/knots
         str
         (if (eq? #t port)
             (current-output-port)
             port)))))

(define &knots-exception
  (make-exception-type '&knots-exception
                       &exception
                       '(stack)))

(define make-knots-exception
  (record-constructor &knots-exception))

(define knots-exception?
  (exception-predicate &knots-exception))

(define knots-exception-stack
  (exception-accessor
   &knots-exception
   (record-accessor &knots-exception 'stack)))

(define* (print-backtrace-and-exception/knots
          exn
          #:key (port (current-error-port)))
  (define (get-string port stack)
    (define stack-len
      (stack-length stack))

    (let ((knots-stacks
           (map knots-exception-stack
                (filter knots-exception?
                        (simple-exceptions exn)))))

      (let* ((stack-vec
              (stack->vector stack))
             (stack-vec-length
              (vector-length stack-vec)))
        (print-frames (list->vector
                       (drop
                        (vector->list stack-vec)
                        (if (< stack-vec-length 5)
                            0
                            4)))
                      port
                      #:count (stack-length stack)))
      (for-each
       (lambda (stack)
         (let* ((stack-vec
                 (stack->vector stack))
                (stack-vec-length
                 (vector-length stack-vec)))
           (print-frames (list->vector
                          (drop
                           (vector->list stack-vec)
                           (if (< stack-vec-length 4)
                               0
                               3)))
                         port
                         #:count (stack-length stack))))
       knots-stacks)
      (print-exception
       port
       (if (null? knots-stacks)
           (stack-ref stack
                      (if (< stack-len 4)
                          stack-len
                          4))
           (let* ((stack (last knots-stacks))
                  (stack-len (stack-length stack)))
             (stack-ref stack
                        (if (< stack-len 3)
                            stack-len
                            3))))
       '%exception
       (list exn))))

  (let* ((stack
          (match (fluid-ref %stacks)
            ((stack-tag . prompt-tag)
             (make-stack #t
                         0 prompt-tag
                         0 (and prompt-tag 1)))
            (_
             (make-stack #t))))
         (string-port
          (open-output-string))
         (error-string
          (with-exception-handler
              (lambda (exn)
                (display/knots (get-output-string string-port)
                               port)
                (close-output-port string-port)
                (display/knots "\n\n" port)

                (let* ((stack (make-stack #t))
                       (backtrace
                        (call-with-output-string
                          (lambda (port)
                            (display-backtrace stack port)
                            (newline port)))))
                  (display/knots backtrace))
                (simple-format/knots
                 port
                 "\nexception in print-backtrace-and-exception/knots: ~A\n"
                 exn)
                (raise-exception exn))
            (lambda ()
              (get-string string-port stack)
              (let ((str (get-output-string string-port)))
                (close-output-port string-port)
                str)))))
    (display/knots error-string port)))

(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?)
  "Spawn a fiber to run THUNK, with knots exception handling.

Accepts the same optional SCHEDULER and @code{#:parallel?} arguments
as @code{spawn-fiber}."
  (spawn-fiber
   (lambda ()
     (with-exception-handler
         (lambda (exn)
           (display/knots "Uncaught exception in task:\n"
                          (current-error-port))
           (print-backtrace-and-exception/knots exn))
       (lambda ()
         (with-exception-handler
             (lambda (exn)
               (let ((stack
                      (match (fluid-ref %stacks)
                        ((stack-tag . prompt-tag)
                         (make-stack #t
                                     0 prompt-tag
                                     0 (and prompt-tag 1)))
                        (_
                         (make-stack #t)))))
                 (raise-exception
                  (make-exception
                   exn
                   (make-knots-exception stack)))))
           thunk))
       #:unwind? #t))
   scheduler
   #:parallel? parallel?))