05/05: packages: Delete duplicate inputs when lowering bags.

[guix-commits]

civodul pushed a commit to branch core-updates
in repository guix.

commit 6b4663363c061071c10209f71aed1017a241af6c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Oct 15 23:01:57 2020 +0200

    packages: Delete duplicate inputs when lowering bags.
    
    This is a followup to 18fa433bf5c420868562b9f4b017c5c97251a44b and
    <https://issues.guix.gnu.org/43508>.
    
    * guix/packages.scm (derivation=?, input=?): New procedures.
    (bag->derivation, bag->cross-derivation): Add calls to
    'delete-duplicates'.
    * tests/packages.scm ("package-derivation, inputs deduplicated"): New
    test.
---
 guix/packages.scm  | 28 ++++++++++++++++++++++++----
 tests/packages.scm | 13 +++++++++++++
 2 files changed, 37 insertions(+), 4 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 865cb81..5ad27fa 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1322,6 +1322,22 @@ TARGET."
          (bag     (package->bag package system target)))
     (bag-grafts store bag)))
 
+(define-inlinable (derivation=? drv1 drv2)
+  "Return true if DRV1 and DRV2 are equal."
+  (or (eq? drv1 drv2)
+      (string=? (derivation-file-name drv1)
+                (derivation-file-name drv2))))
+
+(define (input=? input1 input2)
+  "Return true if INPUT1 and INPUT2 are equivalent."
+  (match input1
+    ((label1 drv1 . outputs1)
+     (match input2
+       ((label2 drv2 . outputs2)
+        (and (string=? label1 label2)
+             (equal? outputs1 outputs2)
+             (derivation=? drv1 drv2)))))))
+
 (define* (bag->derivation store bag
                           #:optional context)
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
@@ -1340,9 +1356,12 @@ error reporting."
                                          p))
                                        (_ '()))
                                       inputs))))
-
+        ;; It's possible that INPUTS contains packages that are not 'eq?' but
+        ;; that lead to the same derivation.  Delete those duplicates to avoid
+        ;; issues down the road, such as duplicate entries in '%build-inputs'.
         (apply (bag-build bag)
-               store (bag-name bag) input-drvs
+               store (bag-name bag)
+               (delete-duplicates input-drvs input=?)
                #:search-paths paths
                #:outputs (bag-outputs bag) #:system system
                (bag-arguments bag)))))
@@ -1380,8 +1399,9 @@ This is an internal procedure."
 
     (apply (bag-build bag)
            store (bag-name bag)
-           #:native-drvs build-drvs
-           #:target-drvs (append host-drvs target-drvs)
+           #:native-drvs (delete-duplicates build-drvs input=?)
+           #:target-drvs (delete-duplicates (append host-drvs target-drvs)
+                                            input=?)
            #:search-paths paths
            #:native-search-paths npaths
            #:outputs (bag-outputs bag)
diff --git a/tests/packages.scm b/tests/packages.scm
index cbd0503..2649c24 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -611,6 +611,19 @@
     (and (derivation? drv)
          (file-exists? (derivation-file-name drv)))))
 
+(test-assert "package-derivation, inputs deduplicated"
+  (let* ((dep (dummy-package "dep"))
+         (p0  (dummy-package "p" (inputs `(("dep" ,dep)))))
+         (p1  (package (inherit p0)
+                       (inputs `(("dep" ,(package (inherit dep)))
+                                 ,@(package-inputs p0))))))
+    ;; Here P1 ends up with two non-eq? copies of DEP, under the same label.
+    ;; They should be deduplicated so that P0 and P1 lead to the same
+    ;; derivation rather than P1 ending up with duplicate entries in its
+    ;; '%build-inputs' variable.
+    (string=? (derivation-file-name (package-derivation %store p0))
+              (derivation-file-name (package-derivation %store p1)))))
+
 (test-assert "package-output"
   (let* ((package  (dummy-package "p"))
          (drv      (package-derivation %store package)))