mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
offload: Make 'parallel-builds' a hard limit.
* guix/scripts/offload.scm (machine-choice-lock-file, machine-slot-file, acquire-build-slot, release-build-slot): New procedures. (choose-build-machine): Operate with (machine-choice-lock-file) taken. Acquire a build slot for each of MACHINES. Release those not used.
This commit is contained in:
parent
4bf1eb4f88
commit
d652b85137
1 changed files with 82 additions and 9 deletions
|
@ -309,6 +309,10 @@ (define (machine-lock-file machine hint)
|
||||||
(build-machine-name machine)
|
(build-machine-name machine)
|
||||||
"." (symbol->string hint) ".lock"))
|
"." (symbol->string hint) ".lock"))
|
||||||
|
|
||||||
|
(define (machine-choice-lock-file)
|
||||||
|
"Return the name of the file used as a lock when choosing a build machine."
|
||||||
|
(string-append %state-directory "/offload/machine-choice.lock"))
|
||||||
|
|
||||||
(define (lock-file file)
|
(define (lock-file file)
|
||||||
"Wait and acquire an exclusive lock on FILE. Return an open port."
|
"Wait and acquire an exclusive lock on FILE. Return an open port."
|
||||||
(mkdir-p (dirname file))
|
(mkdir-p (dirname file))
|
||||||
|
@ -339,17 +343,86 @@ (define-syntax-rule (with-machine-lock machine hint exp ...)
|
||||||
(with-file-lock (machine-lock-file machine hint)
|
(with-file-lock (machine-lock-file machine hint)
|
||||||
exp ...))
|
exp ...))
|
||||||
|
|
||||||
|
|
||||||
|
(define (machine-slot-file machine slot)
|
||||||
|
"Return the file name of MACHINE's file for SLOT."
|
||||||
|
;; For each machine we have a bunch of files representing each build slot.
|
||||||
|
;; When choosing a build machine, we attempt to get an exclusive lock on one
|
||||||
|
;; of these; if we fail, that means all the build slots are already taken.
|
||||||
|
;; Inspired by Nix's build-remote.pl.
|
||||||
|
(string-append (string-append %state-directory "/offload/"
|
||||||
|
(build-machine-name machine)
|
||||||
|
"/" (number->string slot))))
|
||||||
|
|
||||||
|
(define (acquire-build-slot machine)
|
||||||
|
"Attempt to acquire a build slot on MACHINE. Return the port representing
|
||||||
|
the slot, or #f if none is available.
|
||||||
|
|
||||||
|
This mechanism allows us to set a hard limit on the number of simultaneous
|
||||||
|
connections allowed to MACHINE."
|
||||||
|
(mkdir-p (dirname (machine-slot-file machine 0)))
|
||||||
|
(with-machine-lock machine 'slots
|
||||||
|
(any (lambda (slot)
|
||||||
|
(let ((port (open-file (machine-slot-file machine slot)
|
||||||
|
"w0")))
|
||||||
|
(catch 'flock-error
|
||||||
|
(lambda ()
|
||||||
|
(fcntl-flock port 'write-lock #:wait? #f)
|
||||||
|
;; Got it!
|
||||||
|
(format (current-error-port)
|
||||||
|
"process ~a acquired build slot '~a'~%"
|
||||||
|
(getpid) (port-filename port))
|
||||||
|
port)
|
||||||
|
(lambda args
|
||||||
|
;; PORT is already locked by another process.
|
||||||
|
(close-port port)
|
||||||
|
#f))))
|
||||||
|
(iota (build-machine-parallel-builds machine)))))
|
||||||
|
|
||||||
|
(define (release-build-slot slot)
|
||||||
|
"Release SLOT, a build slot as returned as by 'acquire-build-slot'."
|
||||||
|
(close-port slot))
|
||||||
|
|
||||||
(define (choose-build-machine requirements machines)
|
(define (choose-build-machine requirements machines)
|
||||||
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
|
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
|
||||||
(let ((machines (sort (filter (cut machine-matches? <> requirements)
|
|
||||||
machines)
|
;; Proceed like this:
|
||||||
machine-less-loaded-or-faster?)))
|
;; 1. Acquire the global machine-choice lock.
|
||||||
(match machines
|
;; 2. For all MACHINES, attempt to acquire a build slot, and filter out
|
||||||
((head . _)
|
;; those machines for which we failed.
|
||||||
;; Return the best machine unless it's already overloaded.
|
;; 3. Choose the best machine among those that are left.
|
||||||
(and (< (machine-load head) 2.)
|
;; 4. Release the previously-acquired build slots of the other machines.
|
||||||
head))
|
;; 5. Release the global machine-choice lock.
|
||||||
(_ #f))))
|
|
||||||
|
(with-file-lock (machine-choice-lock-file)
|
||||||
|
(define machines+slots
|
||||||
|
(map (lambda (machine)
|
||||||
|
(let ((slot (acquire-build-slot machine)))
|
||||||
|
(and slot (list machine slot))))
|
||||||
|
machines))
|
||||||
|
|
||||||
|
(define (undecorate pred)
|
||||||
|
(match-lambda
|
||||||
|
((machine slot)
|
||||||
|
(and (pred machine)
|
||||||
|
(list machine slot)))))
|
||||||
|
|
||||||
|
(let ((machines+slots (sort (filter (undecorate
|
||||||
|
(cut machine-matches? <> requirements))
|
||||||
|
machines+slots)
|
||||||
|
(undecorate machine-less-loaded-or-faster?))))
|
||||||
|
(match machines+slots
|
||||||
|
(((best slot) (others slots) ...)
|
||||||
|
;; Release slots from the uninteresting machines.
|
||||||
|
(for-each release-build-slot slots)
|
||||||
|
|
||||||
|
;; Return the best machine unless it's already overloaded.
|
||||||
|
(if (< (machine-load best) 2.)
|
||||||
|
best
|
||||||
|
(begin
|
||||||
|
(release-build-slot slot)
|
||||||
|
#f)))
|
||||||
|
(() #f)))))
|
||||||
|
|
||||||
(define* (process-request wants-local? system drv features
|
(define* (process-request wants-local? system drv features
|
||||||
#:key
|
#:key
|
||||||
|
|
Loading…
Reference in a new issue