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.

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 ()
+       (parameterize ((%critical-section-args args))
          (let loop ()
            (match (get-message channel)
              (((? channel? reply) . (? procedure? proc))
               (put-message reply (apply proc args))))
-         (loop))))
+           (loop)))))
     channel))
 
 (define (call-with-critical-section channel proc)
-  "Call PROC in the critical section corresponding to CHANNEL.  Return the
-result of PROC."
+  "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)))
+          (get-message reply)))))
 
 (define-syntax-rule (with-critical-section channel (vars ...) exp ...)
   "Evaluate EXP... in the critical section corresponding to CHANNEL.