GNU bug report logs - #32121
Cuirass: add support for multiple inputs

Previous Next

Full log

Message #11 received at 32121 <at> debbugs.gnu.org (full text, mbox):

From: Clément Lassieur <clement <at> lassieur.org>
To: 32121 <at> debbugs.gnu.org
Subject: [PATCH 2/5] utils: Reset the Fiber dynamic environment in
 %NON-BLOCKING.
Date: Wed, 11 Jul 2018 01:02:44 +0200

* 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 <ludo <at> gnu.org>
 ;;; Copyright © 2015 David Thompson <davet <at> gnu.org>
 ;;; Copyright © 2016 Mathieu Lirzin <mthl <at> gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement <at> 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
-- 
2.18.0

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.