ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-12 06:06:53 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source 
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 @@ (define (machine-choice-lock-file)
"Return the name of the file used as a lock when choosing a build machine." "Return the name of the file used as a lock when choosing a build machine."
(string-append %state-directory "/offload/machine-choice.lock")) (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) (define (choose-build-machine machines)
"Return two values: the best machine among MACHINES and its build "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." slot (which must later be released with 'release-build-slot'), or #f and #f."
@ -441,39 +458,35 @@ (define (choose-build-machine 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+loads (define machines+slots
(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 (and slot (list machine slot))))
(list machine slot (machine-load machine))))) (shuffle machines)))
machines))
(define (undecorate pred) (define (undecorate pred)
(lambda (a b) (lambda (a b)
(match a (match a
((machine1 slot1 load1) ((machine1 slot1)
(match b (match b
((machine2 slot2 load2) ((machine2 slot2)
(pred machine1 load1 machine2 load2))))))) (pred machine1 machine2)))))))
(define (machine-less-loaded-or-faster? m1 l1 m2 l2) (define (machine-faster? m1 m2)
;; Return #t if M1 is either less loaded or faster than M2, with L1 ;; Return #t if M1 is faster than M2.
;; being the load of M1 and L2 the load of M2. (This relation defines a (> (build-machine-speed m1)
;; total order on machines.) (build-machine-speed m2)))
(> (/ (build-machine-speed m1) (+ 1 l1))
(/ (build-machine-speed m2) (+ 1 l2))))
(let loop ((machines+slots+loads (let loop ((machines+slots
(sort machines+slots+loads (sort machines+slots (undecorate machine-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 (< 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 (match others
(((machines slots loads) ...) (((machines slots) ...)
;; Release slots from the uninteresting machines. ;; Release slots from the uninteresting machines.
(for-each release-build-slot slots) (for-each release-build-slot slots)