Don't use threads for substituting derivations

Instead use non-blocking store connections like Cuirass does.

3 files changed, 37 insertions, 39 deletions

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 4c1702d..05e9695 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -64,8 +64,7 @@
 (define (start-client-request-server secret-key-base
                                      host
                                      port
-                                     build-coordinator
-                                     substitutes-channel)
+                                     build-coordinator)
   (run-server/patched
    (lambda (request body)
      (log-msg (build-coordinator-logger build-coordinator)
@@ -80,8 +79,7 @@
                                (uri-path (request-uri request))))
                         body
                         secret-key-base
-                        build-coordinator
-                        substitutes-channel)))
+                        build-coordinator)))
    #:host host
    #:port port))
 
@@ -89,8 +87,7 @@
                     method-and-path-components
                     raw-body
                     secret-key-base
-                    build-coordinator
-                    substitutes-channel)
+                    build-coordinator)
   (define datastore
     (build-coordinator-datastore build-coordinator))
 
@@ -443,11 +440,8 @@
          (define (read-drv/substitute derivation-file)
            (unless (with-store store
                      (valid-path? store derivation-file))
-             (call-with-worker-thread
-              substitutes-channel
-              (lambda ()
-                (substitute-derivation derivation-file
-                                       #:substitute-urls substitute-urls))))
+             (substitute-derivation derivation-file
+                                    #:substitute-urls substitute-urls))
            (read-derivation-from-file* derivation-file))
 
          (let ((submit-build-result
@@ -469,12 +463,9 @@
                             (if (null? (or substitute-urls '()))
                                 ;; Try again
                                 (read-drv/substitute derivation-file)
-                                (call-with-worker-thread
-                                 substitutes-channel
-                                 (lambda ()
-                                   (read-derivation-through-substitutes
-                                    derivation-file
-                                    substitute-urls)))))
+                                (read-derivation-through-substitutes
+                                 derivation-file
+                                 substitute-urls)))
                         (lambda ()
                           (read-drv/substitute derivation-file))
                         #:unwind? #t))
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 15b6aa0..3dd49e3 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -465,22 +465,6 @@
                "warning: chunked request channel delayed by ~1,2f seconds~%"
                seconds-delayed)))))
 
-
-        (substitutes-channel
-         (make-worker-thread-channel
-          (const '())
-          #:name "substitutes"
-          #:parallelism 16
-          #:delay-logger
-          (lambda (seconds-delayed)
-            (log-delay "substitute channel"
-                       seconds-delayed)
-            (when (> seconds-delayed 0.1)
-              (format
-               (current-error-port)
-               "warning: substitutes channel delayed by ~1,2f seconds~%"
-               seconds-delayed)))))
-
         (output-hash-channel
          (make-output-hash-channel
           build-coordinator)))
@@ -553,8 +537,7 @@
              secret-key-base
              (uri-host client-communication-uri)
              (uri-port client-communication-uri)
-             build-coordinator
-             substitutes-channel)
+             build-coordinator)
 
             (wait finished?))
           #:hz 10
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index 23c4fe2..17cabc8 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -405,6 +405,30 @@
                      substitute-urls)))
     substitute-urls))
 
+(define (non-blocking-port port)
+  "Make PORT non-blocking and return it."
+  (let ((flags (fcntl port F_GETFL)))
+    (when (zero? (logand O_NONBLOCK flags))
+      (fcntl port F_SETFL (logior O_NONBLOCK flags)))
+    port))
+
+(define (ensure-non-blocking-store-connection store)
+  "Mark the file descriptor that backs STORE, a <store-connection>, as
+O_NONBLOCK."
+  (match (store-connection-socket store)
+    ((? file-port? port)
+     (non-blocking-port port))
+    (_ #f)))
+
+(define-syntax-rule (with-store/non-blocking store exp ...)
+  "Like 'with-store', bind STORE to a connection to the store, but ensure that
+said connection is non-blocking (O_NONBLOCK).  Evaluate EXP... in that
+context."
+  (with-store store
+    (ensure-non-blocking-store-connection store)
+    (let ()
+      exp ...)))
+
 (define* (substitute-derivation derivation-name
                                 #:key substitute-urls)
   (let ((log-port (open-output-string)))
@@ -412,7 +436,7 @@
       (lambda ()
         (if (defined? 'ensure-path
               (resolve-module '(guix store)))
-            (with-store store
+            (with-store/non-blocking store
               (apply set-build-options
                      store
                      `(,@(if substitute-urls
@@ -427,7 +451,7 @@
                    (set-store-connection-timeout store)
                    (ensure-path store derivation-name))
                  #:timeout (* 120 1000))))
-            (with-store store
+            (with-store/non-blocking store
               (apply set-build-options
                      store
                      `(#:print-extended-build-trace? #t
@@ -452,7 +476,7 @@
           (close-output-port log-port)
           ;; This is a hack, to ignore errors relating to closing the store
           ;; connection.
-          (if (with-store store
+          (if (with-store/non-blocking store
                 (valid-path? store derivation-name))
               #t
               (begin
@@ -570,7 +594,7 @@
                           #f))
           (error "could not fetch narinfo"))))
 
-  (with-store store
+  (with-store/non-blocking store
     (define (read-derivation-from-file/custom derivation-name)
       (or (hash-ref %derivation-cache derivation-name)