civodul pushed a commit to branch wip-build-accumulator in repository guix.
commit 3bd295546f2b18e35fd7c250b9552795062b218a Author: Ludovic Courtès <l...@gnu.org> AuthorDate: Wed Mar 25 12:45:12 2020 +0100 profiles: Use 'mapm/accumulate-builds'. * guix/profiles.scm (check-for-collisions): Use 'mapm/accumulate-builds' to lower manifest entries. Call 'foldm' over the already-lowered entries. (profile-derivation): Use 'mapm/accumulate-builds' instead of 'mapm' when calling HOOKS. --- guix/profiles.scm | 57 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/guix/profiles.scm b/guix/profiles.scm index 20a2973..7a3961e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -280,29 +280,37 @@ file name." (define lookup (manifest-entry-lookup manifest)) - (with-monad %store-monad + (define candidates + (filter-map (lambda (entry) + (let ((other (lookup (manifest-entry-name entry) + (manifest-entry-output entry)))) + (and other (list entry other)))) + (manifest-entries manifest))) + + (define lower-pair + (match-lambda + ((first second) + (mlet %store-monad ((first (lower-manifest-entry first system + #:target target)) + (second (lower-manifest-entry second system + #:target target))) + (return (list first second)))))) + + ;; Start by lowering CANDIDATES "in parallel". + (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates))) (foldm %store-monad - (lambda (entry result) - (match (lookup (manifest-entry-name entry) - (manifest-entry-output entry)) - ((? manifest-entry? second) ;potential conflict - (mlet %store-monad ((first (lower-manifest-entry entry system - #:target - target)) - (second (lower-manifest-entry second system - #:target - target))) - (if (string=? (manifest-entry-item first) - (manifest-entry-item second)) - (return result) - (raise (condition - (&profile-collision-error - (entry first) - (conflict second))))))) - (#f ;no conflict - (return result)))) + (lambda (entries result) + (match entries + ((first second) + (if (string=? (manifest-entry-item first) + (manifest-entry-item second)) + (return result) + (raise (condition + (&profile-collision-error + (entry first) + (conflict second)))))))) #t - (manifest-transitive-entries manifest)))) + lst))) (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f)) @@ -1521,10 +1529,9 @@ are cross-built for TARGET." #:target target))) (extras (if (null? (manifest-entries manifest)) (return '()) - (mapm %store-monad - (lambda (hook) - (hook manifest)) - hooks)))) + (mapm/accumulate-builds (lambda (hook) + (hook manifest)) + hooks)))) (define inputs (append (filter-map (lambda (drv) (and (derivation? drv)