From b1fea30339f071e8751039fd0e6ef2aa3e6f44fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 20 Sep 2014 12:10:28 +0200 Subject: offload: Try another machine when the "best" machine is overloaded. * guix/scripts/offload.scm (choose-build-machine): When BEST is overloaded, try the other machines. --- guix/scripts/offload.scm | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index b3b502425c..e7cba1380e 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -610,22 +610,25 @@ allowed on MACHINE." (list machine1 slot1) (list machine2 slot2)))))))) - (let ((machines+slots (sort machines+slots - (undecorate machine-less-loaded-or-faster?)))) + (let loop ((machines+slots + (sort 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) - + (((best slot) others ...) ;; Return the best machine unless it's already overloaded. (if (< (machine-load best) 2.) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best)) (begin - ;; Prevent SLOT from being GC'd. - (set! %slots (cons slot %slots)) - best) - (begin + ;; BEST is overloaded, so try the next one. (release-build-slot slot) - #f))) + (loop others)))) (() #f))))) (define* (process-request wants-local? system drv features -- cgit v1.2.3