diff options
| author | Clément Lassieur <clement@lassieur.org> | 2018-07-02 16:39:19 +0200 |
|---|---|---|
| committer | Clément Lassieur <clement@lassieur.org> | 2018-07-14 13:21:56 +0200 |
| commit | cc078a0e98906044941a0ce6a7328d62dac3df1f (patch) | |
| tree | bdf5a46ddaba890059228f954e7ced8599028fb4 | |
| parent | 14f310f3b3e9fecfddce1529ec5631c829f8190c (diff) | |
| download | cuirass-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.scm | 34 |
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 |