From 556a078549811c03a1b96cb53d5c5f33bfade067 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 9 Jun 2021 09:16:27 +0100 Subject: Perform post build actions outside the main work queue This means that the main work queue can start more jobs while others are being finished off, which is particularly important now that the parallelism of uploading outputs is limited. --- guix-build-coordinator/agent.scm | 125 ++++++++++++++++++++++++--------------- 1 file changed, 76 insertions(+), 49 deletions(-) diff --git a/guix-build-coordinator/agent.scm b/guix-build-coordinator/agent.scm index b89c1f8..dc44251 100644 --- a/guix-build-coordinator/agent.scm +++ b/guix-build-coordinator/agent.scm @@ -103,8 +103,10 @@ (write-textfile metrics-registry metrics-file))) + (define parallel-uploads + 3) (define upload-slots - (make-vector 3 #f)) + (make-vector parallel-uploads #f)) (define queued-uploads '()) @@ -161,7 +163,6 @@ (define (free-slot index) (with-mutex uploads-mutex - (peek "FREEING SLOT" index) (vector-set! upload-slots index #f)) @@ -189,8 +190,6 @@ free-index upload-progress-record) - (peek "USING SLOT" free-index) - (set! queued-uploads (delete file queued-uploads string=?)) @@ -218,7 +217,7 @@ (loop)))))) - (define (process-job build) + (define (process-job build perform-post-build-actions) (let ((build-id (assoc-ref build "uuid")) (derivation-name (or (assoc-ref build "derivation_name") (assoc-ref build "derivation-name"))) @@ -256,27 +255,30 @@ ;; TODO Check this handles timezones right (end-time (localtime (time-second (current-time)) "UTC"))) - (agent-submit-log-file lgr - coordinator-interface - build-id derivation-name) - - (if result - (post-build-success lgr - coordinator-interface - build-id - derivation-name - end-time - submit-outputs? - with-upload-slot) - (post-build-failure lgr - coordinator-interface - build-id - derivation-name - end-time))) - (log-msg lgr 'INFO - build-id - ": finished processing: " - derivation-name)) + (perform-post-build-actions + build + (lambda () + (agent-submit-log-file lgr + coordinator-interface + build-id derivation-name) + + (if result + (post-build-success lgr + coordinator-interface + build-id + derivation-name + end-time + submit-outputs? + with-upload-slot) + (post-build-failure lgr + coordinator-interface + build-id + derivation-name + end-time)) + (log-msg lgr 'INFO + build-id + ": finished processing: " + derivation-name))))) (begin (log-msg lgr 'INFO build-id @@ -300,32 +302,54 @@ (log-msg lgr 'INFO "starting agent " uuid) (log-msg lgr 'INFO "connecting to coordinator " (slot-ref coordinator-interface 'coordinator-uri)) - (let-values (((process-job-with-queue count-jobs count-threads list-jobs) - (create-work-queue current-max-builds - process-job - #:thread-start-delay - (make-time time-duration - 0 - (max 20 - (- 121 (* 100 + (let*-values (((perform-post-build-actions count-post-build-jobs + count-post-build-threads + list-post-build-jobs) + (create-work-queue #f ;; One thread per job + (lambda (build thunk) + (thunk)))) + + ((process-job-with-queue count-jobs count-threads list-jobs) + (create-work-queue current-max-builds + (lambda (build) + (process-job build + perform-post-build-actions)) + #:thread-start-delay + (make-time time-duration + 0 + (max 5 + (- 106(* 100 (/ 120 64)))))))) (define (display-info) (display (simple-format #f "current threads: ~A current jobs: ~A\n~A\n" (count-threads) - (count-jobs) - (string-join - (map (match-lambda - ((build-details) - (simple-format - #f " - ~A (priority: ~A) + (+ (count-jobs) (count-post-build-jobs)) + (string-append + (string-join + (map (match-lambda + ((build-details) + (simple-format + #f " - ~A (priority: ~A) + ~A" + (assoc-ref build-details "uuid") + (assoc-ref build-details "priority") + (assoc-ref build-details "derivation-name")))) + (list-jobs)) + "\n") + "\n" + (string-join + (map (match-lambda + ((build-details _) + (simple-format + #f " - ~A (priority: ~A) ~A" - (assoc-ref build-details "uuid") - (assoc-ref build-details "priority") - (assoc-ref build-details "derivation-name")))) - (list-jobs)) - "\n")) + (assoc-ref build-details "uuid") + (assoc-ref build-details "priority") + (assoc-ref build-details "derivation-name")))) + (list-post-build-jobs)) + "\n"))) (current-error-port))) (let ((details (submit-status coordinator-interface @@ -360,9 +384,12 @@ (if (or (< job-count current-threads) (= job-count 0)) (let* ((queued-build-ids - (map (lambda (job-args) - (assoc-ref (car job-args) "uuid")) - (list-jobs))) + (append + (map (lambda (job-args) + (assoc-ref (car job-args) "uuid")) + (append + (list-jobs) + (list-post-build-jobs))))) (fetched-builds (fetch-builds-for-agent coordinator-interface systems @@ -389,7 +416,7 @@ new-builds) (when (null? new-builds) - (sleep 30))) + (sleep 5))) (sleep 3))))))) (define* (build-log-procedure lgr #:optional build-id) -- cgit v1.2.3