rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2017-10-12 14:21:54 +02:00
parent abaee53c80
commit d8e89b1c79
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 35 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
guix/scripts/offload.scm
View File

@ -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)))))))
((machine2 slot2)
(pred machine1 machine2)))))))
(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))))
(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+loads
(sort machines+slots+loads
(undecorate machine-less-loaded-or-faster?))))
(match machines+slots+loads
(((best slot load) others ...)
(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)