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.
This commit is contained in:
Ludovic Courtès 2016-11-26 23:00:36 +01:00
parent c3e2a2471c
commit 1cd1d8a7ea
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 22 additions and 22 deletions

View File

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