[no subject]

[Clément Lassieur]

branch: master
commit cc078a0e98906044941a0ce6a7328d62dac3df1f
Author: Clément Lassieur <address@hidden>
Date:   Mon Jul 2 16:39:19 2018 +0200

    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.
---
 src/cuirass/utils.scm | 34 ++++++++++++++++++----------------
 1 file 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 <address@hidden>
 ;;; Copyright © 2015 David Thompson <address@hidden>
 ;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
+;;; Copyright © 2018 Clément Lassieur <address@hidden>
 ;;;
 ;;; 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