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: Generalize the machine lock mechanism.

Browse source 
* 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:
Ludovic Courtès 2014-03-08 11:29:52 +01:00
parent c7445833eb
commit 178f5828eb
1 changed files with 16 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
guix/scripts/offload.scm
View file

@ -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
;; 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
(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
(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