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:
parent
d2d63e20d5
commit
bc60349b5b
|
@ -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."
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
Loading…
Reference in New Issue