Christopher Baines
094259b049
Which call put-bytevector for performing output. When used in combination with an unbuffered port, this should be safer than using the normal Guile procedures, as I think it'll avoid writing to the buffers, while still avoiding single character at a time output. More research is needed though in to how to output to stdout/stderr when using fibers with a parallelism greater than 1.
222 lines
6.8 KiB
Scheme
222 lines
6.8 KiB
Scheme
(define-module (knots)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 suspendable-ports)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (fibers)
|
|
#: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
|
|
|
|
spawn-fiber/knots))
|
|
|
|
(define (call-with-default-io-waiters thunk)
|
|
(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)
|
|
(let ((start-of-the-year-2000 946684800))
|
|
(while (< (current-time)
|
|
start-of-the-year-2000)
|
|
(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)
|
|
(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* (display/knots obj #:optional (port (current-output-port)))
|
|
(put-bytevector
|
|
port
|
|
(string->utf8
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(display obj port))))))
|
|
|
|
(define (simple-format/knots port s . args)
|
|
(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)
|
|
(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-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?))
|