01/02: offload: Reduce the number of calls to 'machine-load'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d8e89b1c794141b21ae4a87244d2c181b4a8460c
Author: Ludovic Courtès <address@hidden>
Date:   Thu Oct 12 14:21:54 2017 +0200

    offload: Reduce the number of calls to 'machine-load'.
    
    Previously we would call 'machine-load' once per machine, which was very
    costly when there were many machines.  Now we arrange to call it only
    once on average (when all the machines have the same 'speed' value).
    
    * guix/scripts/offload.scm (random-seed, shuffle): New procedures.
    (choose-build-machine)[machines+slots+loads]: Rename to...
    [machines+slots]: ... this.  Remove load from the tuples therein.
    [undecorate]: Adjust accordingly.
    [machine-less-loaded-or-faster?]: Remove.
    [machine-faster?]: New procedure.
    Sort MACHINES+SLOTS according to 'machine-faster?'.  Call
    'machine-load?' as the last thing.
---
 guix/scripts/offload.scm | 61 +++++++++++++++++++++++++++++-------------------
 1 file changed, 37 insertions(+), 24 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index d3cb64d..6a2485a 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)