aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorClément Lassieur <clement@lassieur.org>2018-07-02 16:39:19 +0200
committerClément Lassieur <clement@lassieur.org>2018-07-14 13:21:56 +0200
commitcc078a0e98906044941a0ce6a7328d62dac3df1f (patch)
treebdf5a46ddaba890059228f954e7ced8599028fb4
parent14f310f3b3e9fecfddce1529ec5631c829f8190c (diff)
downloadcuirass-cc078a0e98906044941a0ce6a7328d62dac3df1f.tar
cuirass-cc078a0e98906044941a0ce6a7328d62dac3df1f.tar.gz
utils: Reset the Fiber dynamic environment in %NON-BLOCKING.
* src/cuirass/utils.scm (%non-blocking): Wrap body in PARAMETERIZE form that clears CURRENT-FIBER. So that PUT-MESSAGE doesn't try to suspend itself within CALL-WITH-NEW-THREAD. See https://lists.gnu.org/archive/html/guile-devel/2018-07/msg00009.html.
-rw-r--r--src/cuirass/utils.scm34
1 files changed, 18 insertions, 16 deletions
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index bbecfb6..d219a3e 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
;;;
@@ -122,22 +123,23 @@ VARS... are bound to the arguments of the critical section."
(lambda (vars ...) exp ...)))
(define (%non-blocking thunk)
- (let ((channel (make-channel)))
- (call-with-new-thread
- (lambda ()
- (catch #t
- (lambda ()
- (call-with-values thunk
- (lambda values
- (put-message channel `(values ,@values)))))
- (lambda args
- (put-message channel `(exception ,@args))))))
-
- (match (get-message channel)
- (('values . results)
- (apply values results))
- (('exception . args)
- (apply throw args)))))
+ (parameterize (((@@ (fibers internal) current-fiber) #f))
+ (let ((channel (make-channel)))
+ (call-with-new-thread
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (call-with-values thunk
+ (lambda values
+ (put-message channel `(values ,@values)))))
+ (lambda args
+ (put-message channel `(exception ,@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