[no subject]

[Clément Lassieur]

branch: master
commit e66e545b69c3adfba6fd1adb0f018f85ceed495f
Author: Clément Lassieur <address@hidden>
Date:   Sun Aug 5 21:10:07 2018 +0200

    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 | 27 +++++++++++++++++----------
 1 file 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.