From 84620dd0c4f8f96cfdafb9a3ce8cce5d36a52b03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Jul 2017 21:55:20 +0200 Subject: offload: Fix potential file descriptor and memory leak. The '%slots' list could grow indefinitely; in practice though, guix-daemon is likely to restart 'guix offload' often enough. * guix/scripts/offload.scm (%slots): Remove. (choose-build-machine): Don't 'set!' %SLOTS. Return the acquired slot as a second value. (process-request): Adjust accordingly. Release the returned slot after 'transfer-and-offload'. --- guix/scripts/offload.scm | 47 +++++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 868f54d1c6..d3cb64d604 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -428,13 +428,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Return the name of the file used as a lock when choosing a build machine." (string-append %state-directory "/offload/machine-choice.lock")) - -(define %slots - ;; List of acquired build slots (open ports). - '()) - (define (choose-build-machine machines) - "Return the best machine among MACHINES, or #f." + "Return two values: the best machine among MACHINES and its build +slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Proceed like this: ;; 1. Acquire the global machine-choice lock. @@ -481,14 +477,15 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) - ;; Prevent SLOT from being GC'd. - (set! %slots (cons slot %slots)) - best)) + ;; The caller must keep SLOT to protect it from GC and to + ;; eventually release it. + (values best slot))) (begin ;; BEST is overloaded, so try the next one. (release-build-slot slot) (loop others)))) - (() #f))))) + (() + (values #f #f)))))) (define* (process-request wants-local? system drv features #:key @@ -506,19 +503,25 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." ;; We'll never be able to match REQS. (display "# decline\n")) ((x ...) - (let ((machine (choose-build-machine candidates))) + (let-values (((machine slot) + (choose-build-machine candidates))) (if machine - (begin - ;; Offload DRV to MACHINE. - (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) - (outputs (string-tokenize (read-line)))) - (transfer-and-offload drv machine - #:inputs inputs - #:outputs outputs - #:max-silent-time max-silent-time - #:build-timeout build-timeout - #:print-build-trace? print-build-trace?))) + (dynamic-wind + (const #f) + (lambda () + ;; Offload DRV to MACHINE. + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? + print-build-trace?))) + (lambda () + (release-build-slot slot))) ;; Not now, all the machines are busy. (display "# postpone\n"))))))) -- cgit 1.4.1