04/06: profiles: Use 'mapm/accumulate-builds'.

[guix-commits]

civodul pushed a commit to branch wip-build-accumulator
in repository guix.

commit 3bd295546f2b18e35fd7c250b9552795062b218a
Author: Ludovic Courtès <address@hidden>
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)