diff --git a/knots.scm b/knots.scm index 01e3738..dee18a5 100644 --- a/knots.scm +++ b/knots.scm @@ -2,6 +2,7 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 suspendable-ports) + #:use-module (fibers) #:use-module (fibers conditions) #:use-module (system repl debug) #:export (call-with-default-io-waiters @@ -15,7 +16,9 @@ knots-exception? knots-exception-stack - print-backtrace-and-exception/knots)) + print-backtrace-and-exception/knots + + spawn-fiber/knots)) (define (call-with-default-io-waiters thunk) (parameterize @@ -149,3 +152,31 @@ (close-output-port string-port) str))))) (display error-string port))) + +(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) + (spawn-fiber + (lambda () + (with-exception-handler + (lambda (exn) + (display "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?))