Merge 'master' into core-updates

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)