From f72f4b48c6777da9465ab17baa6762476d6cb270 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Sep 2021 16:23:48 +0200 Subject: store: 'map/accumulate-builds' processes the whole list in case of cutoff. Fixes . Reported by Lars-Dominik Braun . This fixes a regression introduced in fa81971cbae85b39183ccf8f51e8d96ac88fb4ac whereby 'map/accumulate-builds' would return REST (the tail of LST) without applying PROC on it. The effect would be that 'lower-inputs' in (guix gexp) would dismiss those elements, leading to derivations with correct builders but only a subset of the inputs they should have had. * guix/store.scm (map/accumulate-builds): Add #:cutoff parameter and remove 'accumulation-cutoff' variable. Call PROC on the elements of REST. * tests/store.scm ("map/accumulate-builds cutoff"): New test. --- guix/store.scm | 41 +++++++++++++++++++++++------------------ 1 file changed, 23 insertions(+), 18 deletions(-) (limited to 'guix/store.scm') 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 . - 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 . (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) -- cgit v1.2.3