diff options
| -rw-r--r-- | guix/scripts/offload.scm | 61 |
1 files changed, 37 insertions, 24 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index d3cb64d604..6a2485a007 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -428,6 +428,23 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Return the name of the file used as a lock when choosing a build machine." (string-append %state-directory "/offload/machine-choice.lock")) +(define (random-seed) + (logxor (getpid) (car (gettimeofday)))) + +(define shuffle + (let ((state (seed->random-state (random-seed)))) + (lambda (lst) + "Return LST shuffled (using the Fisher-Yates algorithm.)" + (define vec (list->vector lst)) + (let loop ((result '()) + (i (vector-length vec))) + (if (zero? i) + result + (let* ((j (random i state)) + (val (vector-ref vec j))) + (vector-set! vec j (vector-ref vec (- i 1))) + (loop (cons val result) (- i 1)))))))) + (define (choose-build-machine machines) "Return two values: the best machine among MACHINES and its build slot (which must later be released with 'release-build-slot'), or #f and #f." @@ -441,39 +458,35 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots+loads + (define machines+slots (filter-map (lambda (machine) - ;; Call 'machine-load' from here to make sure it is called - ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot - (list machine slot (machine-load machine))))) - machines)) + (and slot (list machine slot)))) + (shuffle machines))) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1 load1) + ((machine1 slot1) (match b - ((machine2 slot2 load2) - (pred machine1 load1 machine2 load2))))))) - - (define (machine-less-loaded-or-faster? m1 l1 m2 l2) - ;; Return #t if M1 is either less loaded or faster than M2, with L1 - ;; being the load of M1 and L2 the load of M2. (This relation defines a - ;; total order on machines.) - (> (/ (build-machine-speed m1) (+ 1 l1)) - (/ (build-machine-speed m2) (+ 1 l2)))) - - (let loop ((machines+slots+loads - (sort machines+slots+loads - (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots+loads - (((best slot load) others ...) + ((machine2 slot2) + (pred machine1 machine2))))))) + + (define (machine-faster? m1 m2) + ;; Return #t if M1 is faster than M2. + (> (build-machine-speed m1) + (build-machine-speed m2))) + + (let loop ((machines+slots + (sort machines+slots (undecorate machine-faster?)))) + (match machines+slots + (((best slot) others ...) ;; Return the best machine unless it's already overloaded. - (if (< load 2.) + ;; Note: We call 'machine-load' only as a last resort because it is + ;; too costly to call it once for every machine. + (if (< (machine-load best) 2.) (match others - (((machines slots loads) ...) + (((machines slots) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) |