aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/scripts/offload.scm61
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)