aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-09-06 14:41:58 +0200
committerLudovic Courtès <ludo@gnu.org>2019-09-06 14:41:58 +0200
commitbc60349b5bc58a0b803df5adce1de6db82453744 (patch)
treed11777318a93c1f85b579f9e86c7bd402e52b368
parentd2d63e20d5b981009b61bf416b4d7b516e8f1f34 (diff)
downloadguix-bc60349b5bc58a0b803df5adce1de6db82453744.tar
guix-bc60349b5bc58a0b803df5adce1de6db82453744.tar.gz
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.
-rw-r--r--guix/packages.scm30
-rw-r--r--tests/packages.scm36
2 files changed, 47 insertions, 19 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index d9eeee15a2..39ab28d807 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 0478fff237..423c5061aa 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))