;;; Guix Build Coordinator ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of the guix-build-coordinator. ;;; ;;; The Guix Build Coordinator is free software; you can redistribute ;;; it and/or modify it under the terms of the GNU General Public ;;; License as published by the Free Software Foundation; either ;;; version 3 of the License, or (at your option) any later version. ;;; ;;; The Guix Build Coordinator is distributed in the hope that it will ;;; be useful, but WITHOUT ANY WARRANTY; without even the implied ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;;; See the GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with the guix-data-service. If not, see ;;; . (define-module (guix-build-coordinator build-allocator) #:use-module (srfi srfi-1) #:use-module (guix memoization) #:use-module (guix-build-coordinator datastore) #:use-module (guix-build-coordinator coordinator) #:export (basic-build-allocation-strategy)) (define* (basic-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))) (let* ((agents (datastore-list-agents datastore)) (builds (datastore-list-unprocessed-builds 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 builds)))) (for-each (lambda (build) (hash-set! table (assq-ref build 'uuid) (assq-ref build 'priority))) builds) 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) (log "setup failure:" setup-failure) (let ((failure-reason (assq-ref setup-failure 'failure-reason))) (cond ((string=? failure-reason "missing_inputs") ;; missing_inputs setup failures that should be resolved have been ;; filtered out by this point, so this is a relevant setup failure #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 (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 ;; derived-build-priorities-hash to reflect the priorities of builds based ;; on the builds that would be "unblocked" if they were completed. (for-each (lambda (setup-failure-build-id) (let ((setup-failures (hash-ref setup-failures-hash setup-failure-build-id)) (setup-failure-build-derived-priority (hash-ref derived-build-priorities-hash setup-failure-build-id))) (for-each (lambda (setup-failure) (when (string=? "missing_inputs" (assq-ref setup-failure 'failure-reason)) (for-each (lambda (output) (let ((builds (cached/list-builds-for-output output))) (if (any (lambda (output-build) (string=? (or (assq-ref output-build 'result) "unknown") "success")) builds) ;; At least one build for this output has been successful, ;; so delete the setup failure (hash-remove! setup-failures-hash setup-failure-build-id) ;; The missing input isn't available, so set the derived ;; priority to be as least as high as this build (for-each (lambda (build) (when (eq? 0 (assq-ref build 'processed)) (let* ((missing-input-build-id (assq-ref build 'uuid)) (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 (hash-set! derived-build-priorities-hash missing-input-build-id setup-failure-build-derived-priority))))) builds)))) (datastore-list-setup-failure-missing-inputs datastore (assq-ref setup-failure 'id))))) setup-failures))) (hash-map->list (lambda (key value) key) setup-failures-hash)) (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) 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)))) (log "finished") result)))