Add a new allocation strategy

This should work better where the build coordinator is being used to build all
derivations in the graph.

1 files changed, 153 insertions, 1 deletions

diff --git a/guix-build-coordinator/build-allocator.scm b/guix-build-coordinator/build-allocator.scm
index 124cd9b..767d161 100644
--- a/guix-build-coordinator/build-allocator.scm
+++ b/guix-build-coordinator/build-allocator.scm
@@ -23,7 +23,8 @@
   #:use-module (guix memoization)
   #:use-module (guix-build-coordinator datastore)
   #:use-module (guix-build-coordinator coordinator)
-  #:export (basic-build-allocation-strategy))
+  #:export (basic-build-allocation-strategy
+            derivation-ordered-build-allocation-strategy))
 
 (define* (basic-build-allocation-strategy datastore
                                           #:key
@@ -280,3 +281,154 @@
                  agents))))
       (log "finished")
       result)))
+
+(define* (derivation-ordered-build-allocation-strategy
+          datastore
+          #:key
+          (planned-builds-for-agent-limit 2048))
+  (define (log . args)
+    (when #f
+      (simple-format #t "allocator: ~A\n"
+                     (string-join (map (lambda (arg)
+                                         (simple-format #f "~A" arg))
+                                       args)
+                                  " "))))
+
+  (define cached/list-builds-for-output
+    (mlambda (output)
+             (datastore-list-builds-for-output datastore output)))
+
+  (define priority-ordered-unprocessed-builds
+    (datastore-list-unprocessed-builds datastore))
+
+  (let* ((agents (datastore-list-agents datastore))
+         (setup-failures-hash
+          (datastore-fetch-setup-failures datastore))
+         (derived-build-priorities-hash
+          ;; Mapping from build_id to priority, initialised at the individual
+          ;; priorities for the builds
+          (let ((table (make-hash-table
+                        (length priority-ordered-unprocessed-builds))))
+            (for-each (lambda (build)
+                        (hash-set! table
+                                   (assq-ref build 'uuid)
+                                   (assq-ref build 'priority)))
+                      priority-ordered-unprocessed-builds)
+            table)))
+
+    (define (filter-builds-for-agent agent-id)
+      (define (relevant-setup-failure? setup-failure)
+        (log "setup failure:" setup-failure)
+        (let ((failure-reason
+               (assq-ref setup-failure 'failure-reason)))
+          (cond
+           ((string=? failure-reason "missing_inputs")
+            #t)
+           ((string=? failure-reason "could_not_delete_outputs")
+            ;; This problem might go away, but just don't try the same agent
+            ;; again for now.
+            (string=? (assq-ref setup-failure 'agent-id)
+                      agent-id))
+           (else
+            (error "Unknown setup failure " failure-reason)))))
+
+      (lambda (build)
+        (log "build:" (assq-ref build 'uuid))
+        (let* ((build-id (assq-ref build 'uuid))
+               (setup-failures-for-build
+                (or (hash-ref setup-failures-hash build-id)
+                    '()))
+               (relevant-setup-failures
+                (filter relevant-setup-failure?
+                        setup-failures-for-build)))
+          (log "relevant setup failures:" relevant-setup-failures)
+          (if (null? relevant-setup-failures)
+              #t
+              #f))))
+
+    (define (build-sorting-function-for-agent agent-id)
+      (lambda (a b)
+        (let ((a-priority (hash-ref derived-build-priorities-hash
+                                    (assq-ref a 'uuid)))
+              (b-priority (hash-ref derived-build-priorities-hash
+                                    (assq-ref b 'uuid))))
+          (< b-priority a-priority))))
+
+    (define (limit-planned-builds builds)
+      (if planned-builds-for-agent-limit
+          (if (> (length builds) planned-builds-for-agent-limit)
+              (take builds planned-builds-for-agent-limit)
+              builds)
+          builds))
+
+    (define processable-builds
+      (filter (lambda (build)
+                (every (lambda (derivation-input-details)
+                         (let ((builds (cached/list-builds-for-output
+                                        (assq-ref derivation-input-details
+                                                  'output))))
+                           (if (any (lambda (output-build)
+                                      (string=? (or (assq-ref output-build 'result)
+                                                    "unknown")
+                                                "success"))
+                                    builds)
+                               #t
+                               #f)))
+                       (datastore-find-derivation-inputs
+                        datastore
+                        (assq-ref build 'derivation-name))))
+              priority-ordered-unprocessed-builds))
+
+    (for-each (lambda (build)
+                (define build-derived-priority
+                  (hash-ref derived-build-priorities-hash
+                            (assq-ref build 'uuid)))
+
+                (for-each
+                 (lambda (required-build-id)
+                   (let ((required-build-derived-priority
+                          (hash-ref derived-build-priorities-hash
+                                    required-build-id)))
+                     ;; The derived-build-priorities hash only includes
+                     ;; unprocessed builds, so ignore entries without a
+                     ;; priority
+                     (unless (eq? #f required-build-derived-priority)
+                       (when (> build-derived-priority
+                                required-build-derived-priority)
+                         (hash-set! derived-build-priorities-hash
+                                    required-build-id
+                                    build-derived-priority)))))
+                 (datastore-list-builds-for-derivation-recursive-inputs
+                  datastore
+                  (assq-ref build 'derivation-name))))
+              (take priority-ordered-unprocessed-builds
+                    ;; No exact reason to use this here, but it at least means
+                    ;; the builds to consider is propotional in some way to
+                    ;; the maximum number of planned builds per agent
+                    planned-builds-for-agent-limit))
+
+    (let ((result
+           (append-map
+            (lambda (agent-id)
+              (log "considering builds for" agent-id)
+              (let ((builds-sorted-by-derived-priority
+                     (sort (filter (filter-builds-for-agent agent-id)
+                                   processable-builds)
+                           (build-sorting-function-for-agent agent-id))))
+                (if (null? builds-sorted-by-derived-priority)
+                    '()
+                    (let ((builds-for-agent
+                           (limit-planned-builds builds-sorted-by-derived-priority)))
+                      (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))))
+      (log "finished")
+      result)))