diff options
| -rw-r--r-- | guix/store.scm | 41 | ||||
| -rw-r--r-- | tests/store.scm | 36 |
2 files changed, 59 insertions, 18 deletions
diff --git a/guix/store.scm b/guix/store.scm index 0463b0e8fa..89a719bcfc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1355,14 +1355,16 @@ on the build output of a previous derivation." (unresolved things continue) (continue #t))) -(define (map/accumulate-builds store proc lst) +(define* (map/accumulate-builds store proc lst + #:key (cutoff 30)) "Apply PROC over each element of LST, accumulating 'build-things' calls and -coalescing them into a single call." - (define accumulation-cutoff - ;; Threshold above which we stop accumulating unresolved nodes to avoid - ;; pessimal behavior where we keep stumbling upon the same .drv build - ;; requests with many incoming edges. See <https://bugs.gnu.org/49439>. - 30) +coalescing them into a single call. + +CUTOFF is the threshold above which we stop accumulating unresolved nodes." + + ;; The CUTOFF parameter helps avoid pessimal behavior where we keep + ;; stumbling upon the same .drv build requests with many incoming edges. + ;; See <https://bugs.gnu.org/49439>. (define-values (result rest) (let loop ((lst lst) @@ -1373,7 +1375,7 @@ coalescing them into a single call." (match (with-build-handler build-accumulator (proc head)) ((? unresolved? obj) - (if (> unresolved accumulation-cutoff) + (if (>= unresolved cutoff) (values (reverse (cons obj result)) tail) (loop tail (cons obj result) (+ 1 unresolved)))) (obj @@ -1390,17 +1392,20 @@ coalescing them into a single call." ;; REST is necessarily empty. result) (to-build - ;; We've accumulated things TO-BUILD. Actually build them and resume the - ;; corresponding continuations. + ;; We've accumulated things TO-BUILD; build them. (build-things store (delete-duplicates to-build)) - (map/accumulate-builds store - (lambda (obj) - (if (unresolved? obj) - ;; Pass #f because 'build-things' is now - ;; unnecessary. - ((unresolved-continuation obj) #f) - obj)) - (append result rest))))) + + ;; Resume the continuations corresponding to TO-BUILD, and then process + ;; REST. + (append (map/accumulate-builds store + (lambda (obj) + (if (unresolved? obj) + ;; Pass #f because 'build-things' is now + ;; unnecessary. + ((unresolved-continuation obj) #f) + obj)) + result #:cutoff cutoff) + (map/accumulate-builds store proc rest #:cutoff cutoff))))) (define build-things (let ((build (operation (build-things (string-list things) diff --git a/tests/store.scm b/tests/store.scm index 3266fa7a82..95f47c3af3 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -454,6 +454,42 @@ (derivation->output-path drv))) (list d1 d2))))) +(test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264 + (iota 20) + + ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still + ;; returns the right result and calls the build handler by batches. + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (map (lambda (i) + (derivation %store (string-append "the-thing-" + (number->string i)) + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s) + #:properties `((n . ,i)))) + (iota 20))) + (calls '())) + (define lst + (with-build-handler (lambda (continue store things mode) + (set! calls (cons things calls)) + (continue #f)) + (map/accumulate-builds %store + (lambda (d) + (build-derivations %store (list d)) + (assq-ref (derivation-properties d) 'n)) + d + #:cutoff 7))) + + (match (reverse calls) + (((batch1 ...) (batch2 ...) (batch3 ...)) + (and (equal? (map derivation-file-name (take d 8)) batch1) + (equal? (map derivation-file-name (take (drop d 8) 8)) batch2) + (equal? (map derivation-file-name (drop d 16)) batch3) + lst))))) + (test-assert "mapm/accumulate-builds" (let* ((d1 (run-with-store %store (gexp->derivation "foo" #~(mkdir #$output)))) |