Skip to content
Snippets Groups Projects
Commit 178f5828 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

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.
parent c7445833
No related branches found
No related tags found
No related merge requests found
...@@ -303,37 +303,38 @@ (define (machine-less-loaded-or-faster? m1 m2) ...@@ -303,37 +303,38 @@ (define (machine-less-loaded-or-faster? m1 m2)
(or (machine-less-loaded? m1 m2) (or (machine-less-loaded? m1 m2)
(machine-faster? m1 m2))) (machine-faster? m1 m2)))
(define (machine-lock-file machine) (define (machine-lock-file machine hint)
"Return the name of MACHINE's lock file." "Return the name of MACHINE's lock file for HINT."
(string-append %state-directory "/offload/" (string-append %state-directory "/offload/"
(build-machine-name machine) ".lock")) (build-machine-name machine)
"." (symbol->string hint) ".lock"))
(define (lock-machine machine) (define (lock-machine machine hint)
"Wait to acquire MACHINE's lock, and return the lock." "Wait to acquire MACHINE's lock for HINT, and return the lock."
(let ((file (machine-lock-file machine))) (let ((file (machine-lock-file machine hint)))
(mkdir-p (dirname file)) (mkdir-p (dirname file))
(let ((port (open-file file "w0"))) (let ((port (open-file file "w0")))
(fcntl-flock port 'write-lock) (fcntl-flock port 'write-lock)
port))) port)))
(define (unlock-machine machine lock) (define (unlock-machine lock)
"Unlock LOCK, MACHINE's lock." "Unlock LOCK."
(fcntl-flock lock 'unlock) (fcntl-flock lock 'unlock)
(close-port lock) (close-port lock)
#t) #t)
(define-syntax-rule (with-machine-lock machine exp ...) (define-syntax-rule (with-machine-lock machine hint exp ...)
"Wait to acquire MACHINE's exclusive lock, and evaluate EXP in that "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that
context." context."
(let* ((m machine) (let* ((m machine)
(lock (lock-machine m))) (lock (lock-machine m hint)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
#t) #t)
(lambda () (lambda ()
exp ...) exp ...)
(lambda () (lambda ()
(unlock-machine m lock))))) (unlock-machine lock)))))
(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."
...@@ -365,7 +366,7 @@ (define* (process-request wants-local? system drv features ...@@ -365,7 +366,7 @@ (define* (process-request wants-local? system drv features
;; Acquire MACHINE's exclusive lock to serialize file transfers ;; Acquire MACHINE's exclusive lock to serialize file transfers
;; to/from MACHINE in the presence of several 'offload' hook ;; to/from MACHINE in the presence of several 'offload' hook
;; instance. ;; instance.
(when (with-machine-lock machine (when (with-machine-lock machine 'bandwidth
(send-files (cons (derivation-file-name drv) inputs) (send-files (cons (derivation-file-name drv) inputs)
machine)) machine))
(let ((status (offload drv machine (let ((status (offload drv machine
...@@ -375,7 +376,7 @@ (define* (process-request wants-local? system drv features ...@@ -375,7 +376,7 @@ (define* (process-request wants-local? system drv features
(if (zero? status) (if (zero? status)
(begin (begin
;; Likewise (see above.) ;; Likewise (see above.)
(with-machine-lock machine (with-machine-lock machine 'bandwidth
(retrieve-files outputs machine)) (retrieve-files outputs machine))
(format (current-error-port) (format (current-error-port)
"done with offloaded '~a'~%" "done with offloaded '~a'~%"
...@@ -459,7 +460,7 @@ (define not-coma ...@@ -459,7 +460,7 @@ (define not-coma
(leave (_ "invalid arguments: ~{~s ~}~%") x)))) (leave (_ "invalid arguments: ~{~s ~}~%") x))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'with-machine-lock 'scheme-indent-function 1) ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
;;; End: ;;; End:
;;; offload.scm ends here ;;; offload.scm ends here
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment