store: 'map/accumulate-builds' processes the whole list in case of cutoff.

Fixes <https://issues.guix.gnu.org/50264>.
Reported by Lars-Dominik Braun <lars@6xq.net>.

This fixes a regression introduced in
fa81971cba 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.
This commit is contained in:
Ludovic Courtès 2021-09-15 16:23:48 +02:00
parent a840caccae
commit f72f4b48c6
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 59 additions and 18 deletions

View file

@ -1355,14 +1355,16 @@ (define (build-accumulator continue store things mode)
(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 @@ (define-values (result rest)
(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 @@ (define-values (result rest)
;; 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)

View file

@ -454,6 +454,42 @@ (define (same? x y)
(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))))