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:
parent
c3e2a2471c
commit
1cd1d8a7ea
|
@ -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)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue