From 387909454c835c994414aa740a2d33d288064158 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Oct 2020 18:55:54 +0100 Subject: 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(-) (limited to 'src') diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 1966ad6..7f4cc3c 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)) -- cgit v1.2.3