Push builds that should be ready to start to the front of the queue

In the basic allocator.

1 files changed, 41 insertions, 27 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index e1cb160..dbf09d0 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -83,6 +83,8 @@
          ;; used as the key, the build_ids given as the value should happen
          ;; first.
          (build-ordering-hints-hash
+          (make-hash-table))
+         (builds-ready-to-go-hash
           (make-hash-table)))
 
     (define systems-for-builds
@@ -196,34 +198,43 @@
 
       (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)
+      (define (push-deferred-builds-to-the-back builds-list)
+        (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)
-                          builds-to-defer))
-                  (loop result
-                        (cdr builds)
-                        (cons build builds-to-defer)))))))
+                          (cons build builds-to-defer)))))))
+
+      (let-values (((ready-builds other-builds)
+                    (partition (lambda (build)
+                                 (hash-ref builds-ready-to-go-hash
+                                           (assq-ref build 'uuid)))
+                               builds-list)))
+        (append ready-builds
+                (push-deferred-builds-to-the-back other-builds))))
 
     (define (treat-build-as-required build-id required-build-id priority)
       (let ((required-build-derived-priority
@@ -298,6 +309,9 @@
                      (assq-ref setup-failure 'id)))))
               (when (every (lambda (x) (eq? x #t))
                            outputs-should-be-available)
+                (hash-set! builds-ready-to-go-hash
+                           setup-failure-build-id
+                           #t)
                 ;; At least one build for each missing input has been
                 ;; successful, so delete the setup failure from the list of
                 ;; setup failures in the hash