diff options
| -rw-r--r-- | guix-build-coordinator/build-allocator.scm | 117 |
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)))) |