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
0db65c168f).
* 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.
This commit is contained in:
Ludovic Courtès 2019-09-06 14:41:58 +02:00
parent d2d63e20d5
commit bc60349b5b
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 47 additions and 19 deletions

View File

@ -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."

View File

@ -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 "does-not-exist"))
(not (supported-package? p "i686-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")
(supported-package? p "armhf-linux"))))
(test-skip (if (not %store) 8 0))