Perform post build actions outside the main work queue

This means that the main work queue can start more jobs while others are being
finished off, which is particularly important now that the parallelism of
uploading outputs is limited.

1 files changed, 76 insertions, 49 deletions

diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm
index b89c1f8..dc44251 100644
--- a/guix-build-coordinator/agent.scm
+++ b/guix-build-coordinator/agent.scm
@@ -103,8 +103,10 @@
       (write-textfile metrics-registry
                       metrics-file)))
 
+  (define parallel-uploads
+    3)
   (define upload-slots
-    (make-vector 3 #f))
+    (make-vector parallel-uploads #f))
 
   (define queued-uploads
     '())
@@ -161,7 +163,6 @@
 
     (define (free-slot index)
       (with-mutex uploads-mutex
-        (peek "FREEING SLOT" index)
         (vector-set! upload-slots
                      index
                      #f))
@@ -189,8 +190,6 @@
                            free-index
                            upload-progress-record)
 
-              (peek "USING SLOT" free-index)
-
               (set! queued-uploads
                     (delete file queued-uploads string=?))
 
@@ -218,7 +217,7 @@
 
               (loop))))))
 
-  (define (process-job build)
+  (define (process-job build perform-post-build-actions)
     (let ((build-id (assoc-ref build "uuid"))
           (derivation-name (or (assoc-ref build "derivation_name")
                                (assoc-ref build "derivation-name")))
@@ -256,27 +255,30 @@
                        ;; TODO Check this handles timezones right
                        (end-time (localtime (time-second (current-time)) "UTC")))
 
-                  (agent-submit-log-file lgr
-                                         coordinator-interface
-                                         build-id derivation-name)
-
-                  (if result
-                      (post-build-success lgr
-                                          coordinator-interface
-                                          build-id
-                                          derivation-name
-                                          end-time
-                                          submit-outputs?
-                                          with-upload-slot)
-                      (post-build-failure lgr
-                                          coordinator-interface
-                                          build-id
-                                          derivation-name
-                                          end-time)))
-                (log-msg lgr 'INFO
-                         build-id
-                         ": finished processing: "
-                         derivation-name))
+                  (perform-post-build-actions
+                   build
+                   (lambda ()
+                     (agent-submit-log-file lgr
+                                            coordinator-interface
+                                            build-id derivation-name)
+
+                     (if result
+                         (post-build-success lgr
+                                             coordinator-interface
+                                             build-id
+                                             derivation-name
+                                             end-time
+                                             submit-outputs?
+                                             with-upload-slot)
+                         (post-build-failure lgr
+                                             coordinator-interface
+                                             build-id
+                                             derivation-name
+                                             end-time))
+                     (log-msg lgr 'INFO
+                              build-id
+                              ": finished processing: "
+                              derivation-name)))))
               (begin
                 (log-msg lgr 'INFO
                          build-id
@@ -300,32 +302,54 @@
   (log-msg lgr 'INFO "starting agent " uuid)
   (log-msg lgr 'INFO "connecting to coordinator "
            (slot-ref coordinator-interface 'coordinator-uri))
-  (let-values (((process-job-with-queue count-jobs count-threads list-jobs)
-                (create-work-queue current-max-builds
-                                   process-job
-                                   #:thread-start-delay
-                                   (make-time time-duration
-                                              0
-                                              (max 20
-                                                   (- 121 (* 100
+  (let*-values (((perform-post-build-actions count-post-build-jobs
+                                             count-post-build-threads
+                                             list-post-build-jobs)
+                 (create-work-queue #f ;; One thread per job
+                                    (lambda (build thunk)
+                                      (thunk))))
+
+                ((process-job-with-queue count-jobs count-threads list-jobs)
+                 (create-work-queue current-max-builds
+                                    (lambda (build)
+                                      (process-job build
+                                                   perform-post-build-actions))
+                                    #:thread-start-delay
+                                    (make-time time-duration
+                                               0
+                                               (max 5
+                                                    (- 106(* 100
                                                              (/ 120 64))))))))
     (define (display-info)
       (display
        (simple-format
         #f "current threads: ~A current jobs: ~A\n~A\n"
         (count-threads)
-        (count-jobs)
-        (string-join
-         (map (match-lambda
-                ((build-details)
-                 (simple-format
-                  #f " - ~A (priority: ~A)
+        (+ (count-jobs) (count-post-build-jobs))
+        (string-append
+         (string-join
+          (map (match-lambda
+                 ((build-details)
+                  (simple-format
+                   #f " - ~A (priority: ~A)
+     ~A"
+                   (assoc-ref build-details "uuid")
+                   (assoc-ref build-details "priority")
+                   (assoc-ref build-details "derivation-name"))))
+               (list-jobs))
+          "\n")
+         "\n"
+         (string-join
+          (map (match-lambda
+                 ((build-details _)
+                  (simple-format
+                   #f " - ~A (priority: ~A)
      ~A"
-                  (assoc-ref build-details "uuid")
-                  (assoc-ref build-details "priority")
-                  (assoc-ref build-details "derivation-name"))))
-              (list-jobs))
-         "\n"))
+                   (assoc-ref build-details "uuid")
+                   (assoc-ref build-details "priority")
+                   (assoc-ref build-details "derivation-name"))))
+               (list-post-build-jobs))
+          "\n")))
        (current-error-port)))
 
     (let ((details (submit-status coordinator-interface
@@ -360,9 +384,12 @@
           (if (or (< job-count current-threads)
                   (= job-count 0))
               (let* ((queued-build-ids
-                      (map (lambda (job-args)
-                             (assoc-ref (car job-args) "uuid"))
-                           (list-jobs)))
+                      (append
+                       (map (lambda (job-args)
+                              (assoc-ref (car job-args) "uuid"))
+                            (append
+                             (list-jobs)
+                             (list-post-build-jobs)))))
                      (fetched-builds
                       (fetch-builds-for-agent coordinator-interface
                                               systems
@@ -389,7 +416,7 @@
                  new-builds)
 
                 (when (null? new-builds)
-                  (sleep 30)))
+                  (sleep 5)))
               (sleep 3)))))))
 
 (define* (build-log-procedure lgr #:optional build-id)