Try to better order the builds

As well as sorting by priority, this now looks at which builds are missing
outputs, and which builds will provide those outputs and tries to order the
builds providing the outputs before the builds that need them.

1 files changed, 103 insertions, 14 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 02af0b4..7e1b578 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -53,7 +53,12 @@
                                    (assq-ref build 'uuid)
                                    (assq-ref build 'priority)))
                       builds)
-            table)))
+            table))
+         ;; build_id -> (list build_id ...) indicating that for the build_id
+         ;; used as the key, the build_ids given as the value should happen
+         ;; first.
+         (build-ordering-hints-hash
+          (make-hash-table)))
 
     (define (filter-builds-for-agent agent-id)
       (define (relevant-setup-failure? setup-failure)
@@ -102,6 +107,72 @@
               builds)
           builds))
 
+    (define (break-builds-in-to-priority-sublists all-builds)
+      (define (build-priority build)
+        (hash-ref derived-build-priorities-hash
+                  (assq-ref build 'uuid)))
+
+      (let loop ((result '())
+                 (builds all-builds)
+                 (current-priority-builds '())
+                 (current-priority (build-priority (first all-builds))))
+        (if (null? builds)
+            (reverse (cons current-priority-builds result))
+            (let ((build (car builds)))
+              (if (= (build-priority build)
+                     current-priority)
+                  (loop result
+                        (cdr builds)
+                        (cons build current-priority-builds)
+                        current-priority)
+                  (loop (cons current-priority-builds result)
+                        (cdr builds)
+                        (list build)
+                        (build-priority build)))))))
+
+    (define (sort-priority-sublist builds-list)
+      (define (build-id build)
+        (assq-ref build 'uuid))
+
+      (define (builds-that-should-happen-first build-id)
+        (hash-ref build-ordering-hints-hash
+                  build-id
+                  '()))
+
+      (define seen-builds-hash
+        (make-hash-table))
+
+      (define deferred-builds-last-count 0)
+
+      (let loop ((result '())
+                 (builds builds-list)
+                 (builds-to-defer '()))
+        (if (null? builds)
+            (if (null? builds-to-defer)
+                result
+                (if (= (length builds-to-defer)
+                       deferred-builds-last-count)
+                    ;; There can be loops in the graph of missing inputs, so
+                    ;; give up if the ordering doesn't seem to end
+                    (append result builds-to-defer)
+                    (begin (set! deferred-builds-last-count
+                             (length builds-to-defer))
+                           (loop result
+                                 builds-to-defer
+                                 '()))))
+            (let ((build (car builds)))
+              (if (every (lambda (required-build-id)
+                           (hash-ref seen-builds-hash required-build-id))
+                         (builds-that-should-happen-first (build-id build)))
+                  (begin
+                    (hash-set! seen-builds-hash (build-id build) #t)
+                    (loop (cons build result)
+                          (cdr builds)
+                          builds-to-defer))
+                  (loop result
+                        (cdr builds)
+                        (cons build builds-to-defer)))))))
+
     ;; Go through the setup failures and look specifically at the
     ;; missing_inputs ones. Eliminate any missing_inputs failures if all the
     ;; missing inputs appear to have been built successfully, and update the
@@ -140,6 +211,16 @@
                                    (missing-input-build-derived-priority
                                     (hash-ref derived-build-priorities-hash
                                               missing-input-build-id)))
+                              ;; Add an entry to the build-ordering-hints-hash
+                              ;; to indicate that missing-input-build-id
+                              ;; should happen prior to setup-failure-build-id
+                              (hash-set!
+                               build-ordering-hints-hash
+                               setup-failure-build-id
+                               (hash-ref build-ordering-hints-hash
+                                         setup-failure-build-id
+                                         '()))
+
                               (when (> setup-failure-build-derived-priority
                                        missing-input-build-derived-priority)
                                 ;; Bump the priority of the build
@@ -160,19 +241,27 @@
            (append-map
             (lambda (agent-id)
               (log "considering builds for" agent-id)
-              (let ((builds-for-agent
-                     (limit-planned-builds
-                      (sort (filter (filter-builds-for-agent agent-id)
-                                    builds)
-                            (build-sorting-function-for-agent agent-id)))))
-                (map (lambda (build-id ordering)
-                       (list build-id
-                             agent-id
-                             ordering))
-                     (map (lambda (build)
-                            (assq-ref build 'uuid))
-                          builds-for-agent)
-                     (iota (length builds-for-agent)))))
+              (let ((builds-sorted-by-derived-priority
+                     (sort (filter (filter-builds-for-agent agent-id)
+                                   builds)
+                           (build-sorting-function-for-agent agent-id))))
+                (if (null? builds-sorted-by-derived-priority)
+                    '()
+                    (let ((final-ordered-builds
+                           (concatenate
+                            (map sort-priority-sublist
+                                 (break-builds-in-to-priority-sublists
+                                  builds-sorted-by-derived-priority)))))
+                      (let ((builds-for-agent
+                             (limit-planned-builds final-ordered-builds)))
+                        (map (lambda (build-id ordering)
+                               (list build-id
+                                     agent-id
+                                     ordering))
+                             (map (lambda (build)
+                                    (assq-ref build 'uuid))
+                                  builds-for-agent)
+                             (iota (length builds-for-agent))))))))
             (map (lambda (agent)
                    (assq-ref agent 'uuid))
                  agents))))