mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
offload: Generalize the machine lock mechanism.
* guix/scripts/offload.scm (lock-machine): Add 'hint' parameter. (unlock-machine): Remove 'machine' parameter. (with-machine-lock): Add 'hint' parameter, and pass it down. (process-request): Adjust uses of 'with-machine-lock' to pass the 'bandwidth hint.
This commit is contained in:
parent
c7445833eb
commit
178f5828eb
1 changed files with 16 additions and 15 deletions
|
@ -303,37 +303,38 @@ (define (machine-less-loaded-or-faster? m1 m2)
|
|||
(or (machine-less-loaded? m1 m2)
|
||||
(machine-faster? m1 m2)))
|
||||
|
||||
(define (machine-lock-file machine)
|
||||
"Return the name of MACHINE's lock file."
|
||||
(define (machine-lock-file machine hint)
|
||||
"Return the name of MACHINE's lock file for HINT."
|
||||
(string-append %state-directory "/offload/"
|
||||
(build-machine-name machine) ".lock"))
|
||||
(build-machine-name machine)
|
||||
"." (symbol->string hint) ".lock"))
|
||||
|
||||
(define (lock-machine machine)
|
||||
"Wait to acquire MACHINE's lock, and return the lock."
|
||||
(let ((file (machine-lock-file machine)))
|
||||
(define (lock-machine machine hint)
|
||||
"Wait to acquire MACHINE's lock for HINT, and return the lock."
|
||||
(let ((file (machine-lock-file machine hint)))
|
||||
(mkdir-p (dirname file))
|
||||
(let ((port (open-file file "w0")))
|
||||
(fcntl-flock port 'write-lock)
|
||||
port)))
|
||||
|
||||
(define (unlock-machine machine lock)
|
||||
"Unlock LOCK, MACHINE's lock."
|
||||
(define (unlock-machine lock)
|
||||
"Unlock LOCK."
|
||||
(fcntl-flock lock 'unlock)
|
||||
(close-port lock)
|
||||
#t)
|
||||
|
||||
(define-syntax-rule (with-machine-lock machine exp ...)
|
||||
"Wait to acquire MACHINE's exclusive lock, and evaluate EXP in that
|
||||
(define-syntax-rule (with-machine-lock machine hint exp ...)
|
||||
"Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that
|
||||
context."
|
||||
(let* ((m machine)
|
||||
(lock (lock-machine m)))
|
||||
(lock (lock-machine m hint)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
#t)
|
||||
(lambda ()
|
||||
exp ...)
|
||||
(lambda ()
|
||||
(unlock-machine m lock)))))
|
||||
(unlock-machine lock)))))
|
||||
|
||||
(define (choose-build-machine requirements machines)
|
||||
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
|
||||
|
@ -365,7 +366,7 @@ (define* (process-request wants-local? system drv features
|
|||
;; Acquire MACHINE's exclusive lock to serialize file transfers
|
||||
;; to/from MACHINE in the presence of several 'offload' hook
|
||||
;; instance.
|
||||
(when (with-machine-lock machine
|
||||
(when (with-machine-lock machine 'bandwidth
|
||||
(send-files (cons (derivation-file-name drv) inputs)
|
||||
machine))
|
||||
(let ((status (offload drv machine
|
||||
|
@ -375,7 +376,7 @@ (define* (process-request wants-local? system drv features
|
|||
(if (zero? status)
|
||||
(begin
|
||||
;; Likewise (see above.)
|
||||
(with-machine-lock machine
|
||||
(with-machine-lock machine 'bandwidth
|
||||
(retrieve-files outputs machine))
|
||||
(format (current-error-port)
|
||||
"done with offloaded '~a'~%"
|
||||
|
@ -459,7 +460,7 @@ (define not-coma
|
|||
(leave (_ "invalid arguments: ~{~s ~}~%") x))))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-machine-lock 'scheme-indent-function 1)
|
||||
;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
|
||||
;;; End:
|
||||
|
||||
;;; offload.scm ends here
|
||||
|
|
Loading…
Reference in a new issue