From 387909454c835c994414aa740a2d33d288064158 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 27 Oct 2020 18:55:54 +0100
Subject: [PATCH] Use a non-blocking socket for store communication.
Set the store socket as non-blocking so that fibers communicating with the
store don't get blocked as described here: https://issues.guix.gnu.org/43565.
* src/cuirass/base.scm (with-store): Set the store socket as non-blocking.
(build-derivations&): Unset current-read-waiter and current-write-waiter.
---
src/cuirass/base.scm | 17 +++++++++++++++--
1 file changed, 15 insertions(+), 2 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 1966ad6d..7f4cc3ca 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -36,6 +36,9 @@
#:use-module ((guix config) #:select (%state-directory))
#:use-module (git)
#:use-module (ice-9 binary-ports)
+ #:use-module ((ice-9 suspendable-ports)
+ #:select (current-read-waiter
+ current-write-waiter))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -79,7 +82,12 @@
;; currently closes in a 'dynamic-wind' handler, which means it would close
;; the store at each context switch. Remove this when the real 'with-store'
;; has been fixed.
- (let ((store (open-connection)))
+ (let* ((store (open-connection))
+ (socket (store-connection-socket store)))
+ ;; Mark SOCKET as non-blocking so Fibers can schedule the way it wants.
+ (let ((flags (fcntl socket F_GETFL)))
+ (fcntl socket F_SETFL (logior O_NONBLOCK flags)))
+
(unwind-protect
;; Always set #:keep-going? so we don't stop on the first build failure.
;; Set #:print-build-trace explicitly to make sure 'process-build-log'
@@ -422,7 +430,12 @@ Essentially this procedure inverts the inversion-of-control that
(lambda ()
(guard (c ((store-error? c)
(atomic-box-set! result c)))
- (parameterize ((current-build-output-port output))
+ (parameterize ((current-build-output-port output)
+
+ ;; STORE's socket is O_NONBLOCK but since we're
+ ;; not in a fiber, disable Fiber's handlers.
+ (current-read-waiter #f)
+ (current-write-waiter #f))
(let ((x (build-derivations store lst)))
(atomic-box-set! result x))))
(close-port output))
--
GitLab