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.

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 3a64989..ad9878f 100644 (file)
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -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-transitive-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)