02/02: packages: 'supported-package?' binds '%current-system' for graph traversal.

[guix-commits]

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

commit bc60349b5bc58a0b803df5adce1de6db82453744
Author: Ludovic Courtès <address@hidden>
Date:   Fri Sep 6 14:41:58 2019 +0200

    packages: 'supported-package?' binds '%current-system' for graph traversal.
    
    Previously, (supported-package? coreutils "armhf-linux")
    with (%current-system) = "x86_64-linux" would return false.  That's
    because 'supported-package?' would traverse the x86_64 dependency graph,
    which contains 'tcc-boot0', which supports x86 only.
    
    Consequently, 'supported-package?' would match only 53 packages for
    "armhf-linux" when running on x86, as is the case during continuous
    integration.
    
    * guix/packages.scm (package-transitive-supported-systems): Add an
    optional 'system' parameter.  Use 'mlambda' instead of 'mlambdaq' for
    memoization.
    (supported-package?): Pass 'system' to 
'package-transitive-supported-systems'.
    * tests/packages.scm ("package-transitive-supported-systems, implicit 
inputs")
    ("package-transitive-supported-systems: reduced binary seed, implicit 
inputs"):
    Remove calls to 'invalidate-memoization!', which no longer work and were
    presumably introduced to work around the bug we're fixing (see commit
    0db65c168fd6dec57a357735fe130c80feba5460).
    * tests/packages.scm ("supported-package?"): Rewrite test to use only
    existing system name since otherwise 'bootstrap-executable' raises an
    exception.
    ("supported-package? vs. system-dependent graph"): New test.
---
 guix/packages.scm  | 30 ++++++++++++++++++------------
 tests/packages.scm | 36 +++++++++++++++++++++++++++++-------
 2 files changed, 47 insertions(+), 19 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index d9eeee1..39ab28d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -767,23 +767,29 @@ in INPUTS and their transitive propagated inputs."
        (transitive-inputs inputs)))
 
 (define package-transitive-supported-systems
-  (mlambdaq (package)
-    "Return the intersection of the systems supported by PACKAGE and those
+  (let ()
+    (define supported-systems
+      (mlambda (package system)
+        (parameterize ((%current-system system))
+          (fold (lambda (input systems)
+                  (match input
+                    ((label (? package? package) . _)
+                     (lset-intersection string=? systems
+                                        (supported-systems package system)))
+                    (_
+                     systems)))
+                (package-supported-systems package)
+                (bag-direct-inputs (package->bag package))))))
+
+    (lambda* (package #:optional (system (%current-system)))
+      "Return the intersection of the systems supported by PACKAGE and those
 supported by its dependencies."
-    (fold (lambda (input systems)
-            (match input
-              ((label (? package? p) . _)
-               (lset-intersection
-                string=? systems (package-transitive-supported-systems p)))
-              (_
-               systems)))
-          (package-supported-systems package)
-          (bag-direct-inputs (package->bag package)))))
+      (supported-systems package system))))
 
 (define* (supported-package? package #:optional (system (%current-system)))
   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 dependencies are known to build on SYSTEM."
-  (member system (package-transitive-supported-systems package)))
+  (member system (package-transitive-supported-systems package system)))
 
 (define (bag-direct-inputs bag)
   "Same as 'package-direct-inputs', but applied to a bag."
diff --git a/tests/packages.scm b/tests/packages.scm
index 0478fff..423c506 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -341,7 +341,6 @@
                (build-system gnu-build-system)
                (supported-systems
                 `("does-not-exist" "foobar" ,@%supported-systems)))))
-    (invalidate-memoization! package-transitive-supported-systems)
     (parameterize ((%current-system "armhf-linux")) ; a 
traditionally-bootstrapped architecture
       (package-transitive-supported-systems p))))
 
@@ -354,17 +353,40 @@
              (build-system gnu-build-system)
              (supported-systems
               `("does-not-exist" "foobar" ,@%supported-systems)))))
-    (invalidate-memoization! package-transitive-supported-systems)
     (parameterize ((%current-system "x86_64-linux"))
       (package-transitive-supported-systems p))))
 
 (test-assert "supported-package?"
-  (let ((p (dummy-package "foo"
-             (build-system gnu-build-system)
-             (supported-systems '("x86_64-linux" "does-not-exist")))))
+  (let* ((d (dummy-package "dep"
+              (build-system trivial-build-system)
+              (supported-systems '("x86_64-linux"))))
+         (p (dummy-package "foo"
+              (build-system gnu-build-system)
+              (inputs `(("d" ,d)))
+              (supported-systems '("x86_64-linux" "armhf-linux")))))
+    (and (supported-package? p "x86_64-linux")
+         (not (supported-package? p "i686-linux"))
+         (not (supported-package? p "armhf-linux")))))
+
+(test-assert "supported-package? vs. system-dependent graph"
+  ;; The inputs of a package can depend on (%current-system).  Thus,
+  ;; 'supported-package?' must make sure that it binds (%current-system)
+  ;; appropriately before traversing the dependency graph.  In the example
+  ;; below, 'supported-package?' must thus return true for both systems.
+  (let* ((p0a (dummy-package "foo-arm"
+                (build-system trivial-build-system)
+                (supported-systems '("armhf-linux"))))
+         (p0b (dummy-package "foo-x86_64"
+                (build-system trivial-build-system)
+                (supported-systems '("x86_64-linux"))))
+         (p   (dummy-package "bar"
+                (build-system trivial-build-system)
+                (inputs
+                 (if (string=? (%current-system) "armhf-linux")
+                     `(("foo" ,p0a))
+                     `(("foo" ,p0b)))))))
     (and (supported-package? p "x86_64-linux")
-         (not (supported-package? p "does-not-exist"))
-         (not (supported-package? p "i686-linux")))))
+         (supported-package? p "armhf-linux"))))
 
 (test-skip (if (not %store) 8 0))