[no subject]

[Ludovic Courtès]

branch: master
commit 7c697ad7f15c13264615d2b6c9165b21abaf61dd
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Nov 16 23:20:00 2023 +0100

    utils: ‘with-resource-from-pool’ does not suspend from exception handler.
    
    Fixes <https://issues.guix.gnu.org/67041>.
    
    * src/cuirass/utils.scm (call-with-resource-from-pool): Rewrite to avoid
    calling ‘put-message’ from the exception handler.
    * tests/utils.scm ("resource pool, exception thrown"): New test.
---
 src/cuirass/utils.scm | 25 ++++++++++++++++---------
 tests/utils.scm       | 23 ++++++++++++++++++++++-
 2 files changed, 38 insertions(+), 10 deletions(-)

diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 7269f1d..a55a795 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -27,6 +27,7 @@
   #:use-module (system foreign)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-71)
   #:use-module (fibers)
   #:use-module (fibers channels)
   #:use-module (fibers operations)
@@ -90,15 +91,21 @@ as database connections.  The channel can then be passed to
 available.  Return the resource once PROC has returned."
   (let ((reply (make-channel)))
     (put-message pool `(get ,reply))
-    (let ((resource (get-message reply)))
-      (with-exception-handler
-          (lambda (exception)
-            (put-message pool `(put ,resource))
-            (raise-exception exception))
-        (lambda ()
-          (let ((result (proc resource)))
-            (put-message pool `(put ,resource))
-            result))))))
+    (let* ((resource (get-message reply))
+           (type value (with-exception-handler
+                           (lambda (exception)
+                             ;; Note: Do not call 'put-message' from the
+                             ;; handler because 'raise-exception' is a
+                             ;; continuation barrier as of Guile 3.0.9.
+                             (values 'exception exception))
+                         (lambda ()
+                           (let ((result (proc resource)))
+                             (values 'value result)))
+                         #:unwind? #t)))
+      (put-message pool `(put ,resource))
+      (match type
+        ('exception (raise-exception value))
+        ('value value)))))
 
 (define-syntax-rule (with-resource-from-pool pool resource exp ...)
   "Evaluate EXP... with RESOURCE bound to a resource taken from POOL.  When
diff --git a/tests/utils.scm b/tests/utils.scm
index e4384f4..e1ac1b8 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -21,7 +21,8 @@
              (fibers)
              (fibers channels)
              (srfi srfi-1)
-             (srfi srfi-64))
+             (srfi srfi-64)
+             (system base compile))
 
 ;; Enable debugging output.
 (current-logging-level 'debug)
@@ -62,4 +63,24 @@
   (iota 100)
   (run-fibers (resource-pool-test 10 100)))
 
+(test-equal "resource pool, exception thrown"
+  42
+  ;; This test used to hang: 'raise-exception' is written in C and a
+  ;; continuation barrier as of Guile 3.0.9, and a call to 'put-message' from
+  ;; the exception handler would lead to "Attempt to suspend fiber within
+  ;; continuation barrier".  See <https://issues.guix.gnu.org/67041>.
+  (compile
+   '(begin
+      (use-modules (fibers)
+                   (cuirass utils))
+      (run-fibers
+       (lambda ()
+         (define pool (make-resource-pool (iota 10)))
+         (catch 'doh!
+           (lambda ()
+             (with-resource-from-pool pool x
+               (throw 'doh!)))
+           (const 42)))))
+   #:to 'value))
+
 (test-end)