utils: Avoid deadlock when WITH-CRITICAL-SECTION calls are nested.

* src/cuirass/utils.scm (%critical-section-args): New parameter.
(make-critical-section): Put ARGS into a parameter, so that
CALL-WITH-CRITICAL-SECTION knows when it's called from the critical section.
In that case it would just apply PROC to ARGS.
(call-with-critical-section): If already in the critical section, apply PROC
to %CRITICAL-SECTION-ARGS instead of sending the message through the critical
section channel.

1 files changed, 17 insertions, 10 deletions

diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 9e9ac36..6083890 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -94,6 +94,9 @@ delimited continuations and fibers."
         (conclusion)
         (apply throw args)))))
 
+(define %critical-section-args
+  (make-parameter #f))
+
 (define (make-critical-section . args)
   "Return a channel used to implement a critical section.  That channel can
 then be passed to 'join-critical-section', which will ensure sequential
@@ -104,19 +107,23 @@ dedicated fiber."
   (let ((channel (make-channel)))
     (spawn-fiber
      (lambda ()
-       (let loop ()
-         (match (get-message channel)
-           (((? channel? reply) . (? procedure? proc))
-            (put-message reply (apply proc args))))
-         (loop))))
+       (parameterize ((%critical-section-args args))
+         (let loop ()
+           (match (get-message channel)
+             (((? channel? reply) . (? procedure? proc))
+              (put-message reply (apply proc args))))
+           (loop)))))
     channel))
 
 (define (call-with-critical-section channel proc)
-  "Call PROC in the critical section corresponding to CHANNEL.  Return the
-result of PROC."
-  (let ((reply (make-channel)))
-    (put-message channel (cons reply proc))
-    (get-message reply)))
+  "Send PROC to the critical section through CHANNEL.  Return the result of
+PROC.  If already in the critical section, call PROC immediately."
+  (let ((args (%critical-section-args)))
+    (if args
+        (apply proc args)
+        (let ((reply (make-channel)))
+          (put-message channel (cons reply proc))
+          (get-message reply)))))
 
 (define-syntax-rule (with-critical-section channel (vars ...) exp ...)
   "Evaluate EXP... in the critical section corresponding to CHANNEL.