From 6ad9c602697ffe33c8fbb09ccd796b74bf600223 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Wed, 29 Jul 2020 19:08:04 +0200
Subject: [PATCH] utils: Do not block the calling fiber.
Setting current-fiber to #f in %non-blocking will prevent put-message in the
new thread to try suspending itself, but will also cause the same behavior on
get-message, which is not desired.
* src/cuirass/utils.scm (%non-blocking): Reduce the scope of current-fiber
parameter to the newly created thread.
---
src/cuirass/utils.scm | 20 ++++++++++----------
1 file changed, 10 insertions(+), 10 deletions(-)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 0bcbb359..e2a6fa33 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -144,23 +144,23 @@ VARS... are bound to the arguments of the worker thread."
(lambda (vars ...) exp ...)))
(define (%non-blocking thunk)
- (parameterize (((@@ (fibers internal) current-fiber) #f))
- (let ((channel (make-channel)))
- (call-with-new-thread
- (lambda ()
+ (let ((channel (make-channel)))
+ (call-with-new-thread
+ (lambda ()
+ (parameterize (((@@ (fibers internal) current-fiber) #f))
(catch #t
(lambda ()
(call-with-values thunk
(lambda values
(put-message channel `(values ,@values)))))
(lambda args
- (put-message channel `(exception ,@args))))))
+ (put-message channel `(exception ,@args)))))))
- (match (get-message channel)
- (('values . results)
- (apply values results))
- (('exception . args)
- (apply throw args))))))
+ (match (get-message channel)
+ (('values . results)
+ (apply values results))
+ (('exception . args)
+ (apply throw args)))))
(define-syntax-rule (non-blocking exp ...)
"Evalaute EXP... in a separate thread so that it doesn't block the execution
--
GitLab