02/02: offload: Call 'machine-load' only once per machine.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1cd1d8a7ea43bfb99aa05c74da5430bb3d8a4309
Author: Ludovic Courtès <address@hidden>
Date:   Sat Nov 26 23:00:36 2016 +0100

    offload: Call 'machine-load' only once per machine.
    
    This fixes a longstanding issue where 'choose-build-machine' would make
    on average O(N log(N)) calls to 'machine-load', plus an extra call for
    the selected machine, instead of N calls.
    
    * guix/scripts/offload.scm (machine-load): Add comment.
    (machine-power-factor, machine-less-loaded-or-faster?): Remove.
    (choose-build-machine)[machines+slots]: Rename to...
    [machines+slots+loads]: ... this.
    [undecorate]: Adjust accordingly.
    [machine-less-loaded-or-faster?]: New procedure.
    Remove extra 'machine-load' call in body.
---
 guix/scripts/offload.scm |   46 +++++++++++++++++++++++-----------------------
 1 file changed, 23 insertions(+), 23 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 2e02680..bc024a8 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -490,6 +490,7 @@ be read."
 (define (machine-load machine)
   "Return the load of MACHINE, divided by the number of parallel builds
 allowed on MACHINE."
+  ;; Note: This procedure is costly since it creates a new SSH session.
   (let* ((session (open-ssh-session machine))
          (pipe    (open-remote-pipe* session OPEN_READ
                                      "cat" "/proc/loadavg"))
@@ -510,17 +511,6 @@ allowed on MACHINE."
           (_
            +inf.0)))))           ;something's fishy about MACHINE, so avoid it
 
-(define (machine-power-factor m)
-  "Return a factor that aggregates the speed and load of M.  The higher the
-better."
-  (/ (build-machine-speed m)
-     (+ 1 (machine-load m))))
-
-(define (machine-less-loaded-or-faster? m1 m2)
-  "Return #t if M1 is either less loaded or faster than M2.  (This relation
-defines a total order on machines.)"
-  (> (machine-power-factor m1) (machine-power-factor m2)))
-
 (define (machine-lock-file machine hint)
   "Return the name of MACHINE's lock file for HINT."
   (string-append %state-directory "/offload/"
@@ -548,29 +538,39 @@ defines a total order on machines.)"
   ;;   5. Release the global machine-choice lock.
 
   (with-file-lock (machine-choice-lock-file)
-    (define machines+slots
+    (define machines+slots+loads
       (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))))
+                      (and slot
+                           (list machine slot (machine-load machine)))))
                   machines))
 
     (define (undecorate pred)
       (lambda (a b)
         (match a
-          ((machine1 slot1)
+          ((machine1 slot1 load1)
            (match b
-             ((machine2 slot2)
-              (pred machine1 machine2)))))))
-
-    (let loop ((machines+slots
-                (sort machines+slots
+             ((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
-        (((best slot) others ...)
+      (match machines+slots+loads
+        (((best slot load) others ...)
          ;; Return the best machine unless it's already overloaded.
-         (if (< (machine-load best) 2.)
+         (if (< load 2.)
              (match others
-               (((machines slots) ...)
+               (((machines slots loads) ...)
                 ;; Release slots from the uninteresting machines.
                 (for-each release-build-slot slots)