More efficiently filter and select builds in the allocator

Specifically the derivation ordered allocator.

3 files changed, 40 insertions, 53 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 62e9bc9..2591494 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -485,19 +485,8 @@
          (setup-failures-hash
           (datastore-fetch-setup-failures datastore)))
 
-    (define (limit-planned-builds build-ids)
-      (if planned-builds-for-agent-limit
-          (if (> (length build-ids) planned-builds-for-agent-limit)
-              (take build-ids planned-builds-for-agent-limit)
-              build-ids)
-          build-ids))
-
-    (let-values
-        (((derived-build-priorities-hash
-           build-ids-for-unprocessed-builds-with-built-inputs)
-          (datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds
-           datastore
-           builds-created-after)))
+    (let ((prioritised-builds
+           (datastore-fetch-prioritised-unprocessed-builds datastore)))
 
       (define systems-for-builds
         (map (lambda (build-id)
@@ -505,7 +494,7 @@
                      (datastore-find-build-derivation-system
                       datastore
                       build-id)))
-             build-ids-for-unprocessed-builds-with-built-inputs))
+             prioritised-builds))
 
       (define tags-for-build
         (let ((build-tags (make-hash-table)))
@@ -564,36 +553,45 @@
                  #t
                  #f)))))
 
-      (define (build-sorting-function-for-agent agent-id)
-        (lambda (a b)
-          (let ((a-priority (hash-ref derived-build-priorities-hash a))
-                (b-priority (hash-ref derived-build-priorities-hash b)))
-            (< b-priority a-priority))))
-
       (when metrics-registry
         (metric-set allocator-considered-builds-metric
-                    (length build-ids-for-unprocessed-builds-with-built-inputs)))
+                    (length prioritised-builds)))
 
       (let ((result
              (append-map
               (lambda (agent-id)
                 (log "considering builds for" agent-id)
-                (let ((build-ids-sorted-by-derived-priority
-                       (sort
-                        (filter (filter-builds-for-agent agent-id)
-                                build-ids-for-unprocessed-builds-with-built-inputs)
-                        (build-sorting-function-for-agent agent-id))))
-                  (if (null? build-ids-sorted-by-derived-priority)
+                (let* ((filter-proc
+                        (filter-builds-for-agent agent-id))
+                       (build-ids
+                        (let loop ((count 0)
+                                   (build-ids '())
+                                   (potential-build-ids prioritised-builds))
+                          (if (or (and planned-builds-for-agent-limit
+                                       (>= count planned-builds-for-agent-limit))
+                                  (null? potential-build-ids))
+                              build-ids ;; highest priority last
+                              (let ((potential-build (first potential-build-ids)))
+                                (if (filter-proc potential-build)
+                                    (loop (+ 1 count)
+                                          (cons potential-build
+                                                build-ids)
+                                          (cdr potential-build-ids))
+                                    (loop count
+                                          build-ids
+                                          (cdr potential-build-ids))))))))
+                  (if (null? build-ids)
                       '()
-                      (let ((builds-for-agent
-                             (limit-planned-builds
-                              build-ids-sorted-by-derived-priority)))
+                      (let ((build-ids-count
+                             (length build-ids)))
                         (map (lambda (build-id ordering)
                                (list build-id
                                      agent-id
                                      ordering))
-                             builds-for-agent
-                             (iota (length builds-for-agent)))))))
+                             build-ids
+                             (iota build-ids-count
+                                   build-ids-count
+                                   -1))))))
               (map (lambda (agent)
                      (assq-ref agent 'uuid))
                    agents))))
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm
index 1718c31..6bd6944 100644
--- a/guix-build-coordinator/datastore.scm
+++ b/guix-build-coordinator/datastore.scm
@@ -61,7 +61,7 @@
 (re-export datastore-list-processed-builds)
 (re-export datastore-list-unprocessed-builds)
 (re-export datastore-find-first-unallocated-deferred-build)
-(re-export datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds)
+(re-export datastore-fetch-prioritised-unprocessed-builds)
 (re-export datastore-insert-unprocessed-hook-event)
 (re-export datastore-count-unprocessed-hook-events)
 (re-export datastore-list-unprocessed-hook-events)
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 398c3bd..845f8b2 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -75,7 +75,7 @@
             datastore-list-processed-builds
             datastore-list-unprocessed-builds
             datastore-find-first-unallocated-deferred-build
-            datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds
+            datastore-fetch-prioritised-unprocessed-builds
             datastore-insert-unprocessed-hook-event
             datastore-count-unprocessed-hook-events
             datastore-list-unprocessed-hook-events
@@ -2291,15 +2291,14 @@ LIMIT 1"
 
          result)))))
 
-(define-method (datastore-fetch-build-ids-and-propagated-priorities-for-unprocessed-builds
-                (datastore <sqlite-datastore>)
-                created-after)
-  (define (fetch-propagated-priorities-for-unprocessed-builds db)
+(define-method (datastore-fetch-prioritised-unprocessed-builds
+                (datastore <sqlite-datastore>))
+  (define (fetch-prioritised-unprocessed-builds db)
     (let ((statement
            (sqlite-prepare
             db
             "
-SELECT builds.uuid, derived_priority
+SELECT builds.uuid
 FROM unprocessed_builds_with_derived_priorities
 INNER JOIN builds ON build_id = builds.id
 WHERE all_inputs_built = 1
@@ -2313,11 +2312,9 @@ WHERE all_inputs_built = 1
 
       (let ((result (sqlite-fold
                      (lambda (row result)
-                       (match row
-                         (#(uuid derived-priority)
-                          (hash-set! result uuid derived-priority)))
-                       result)
-                     (make-hash-table 10000)
+                       (cons (vector-ref row 0)
+                             result))
+                     '()
                      statement)))
         (sqlite-reset statement)
 
@@ -2325,15 +2322,7 @@ WHERE all_inputs_built = 1
 
   (call-with-worker-thread
    (slot-ref datastore 'worker-reader-thread-channel)
-   (lambda (db)
-     (let* ((propagated-priorities
-             (fetch-propagated-priorities-for-unprocessed-builds db))
-            (unprocessed-build-ids
-             (hash-map->list (lambda (key _) key)
-                             propagated-priorities)))
-
-       (values propagated-priorities
-               unprocessed-build-ids)))))
+   fetch-prioritised-unprocessed-builds))
 
 (define-method (datastore-insert-unprocessed-hook-event
                 (datastore <sqlite-datastore>)