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

@@ -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

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)