me/guix
Archived
1
0
Fork 0
Code Activity

packages: 'package-derivation' honors 'system' again.

Browse source 
Fixes a regression introduced in
7d873f194c.

Starting from 7d873f194c, running

  guix build -s aarch64-linux sed

on an x86_64-linux machine would return an x86_64-linux machine, whereby
only the top derivation of the graph would be aarch64-linux while all
its dependencies would be x86_64-linux.

* guix/packages.scm (expand-input): Add 'system' parameter and honor it.
(bag->derivation, bag->cross-derivation): Pass SYSTEM to 'expand-input'.
* tests/packages.scm ("package-derivation, different system"): New test.
This commit is contained in:
Ludovic Courtès 2021-07-01 21:30:46 +02:00
parent 6bd8501e68
commit 98c075c24e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 28 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
guix/packages.scm
View file

@ -1211,7 +1211,7 @@ Return the cached result when available."
(#f (#f
(cache! cache package key thunk))))))) (cache! cache package key thunk)))))))
(define* (expand-input package input #:key target) (define* (expand-input package input system #:key target)
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
only used to provide contextual information in exceptions." only used to provide contextual information in exceptions."
(with-monad %store-monad (with-monad %store-monad
@ -1224,15 +1224,19 @@ only used to provide contextual information in exceptions."
;; derivation. ;; derivation.
(((? string? name) (? package? package)) (((? string? name) (? package? package))
(mlet %store-monad ((drv (if target (mlet %store-monad ((drv (if target
(package->cross-derivation package target (package->cross-derivation package
target system
#:graft? #f) #:graft? #f)
(package->derivation package #:graft? #f)))) (package->derivation package system
#:graft? #f))))
(return (list name (gexp-input drv #:native? (not target)))))) (return (list name (gexp-input drv #:native? (not target))))))
(((? string? name) (? package? package) (? string? output)) (((? string? name) (? package? package) (? string? output))
(mlet %store-monad ((drv (if target (mlet %store-monad ((drv (if target
(package->cross-derivation package target (package->cross-derivation package
target system
#:graft? #f) #:graft? #f)
(package->derivation package #:graft? #f)))) (package->derivation package system
#:graft? #f))))
(return (list name (gexp-input drv output #:native? (not target)))))) (return (list name (gexp-input drv output #:native? (not target))))))
(((? string? name) (? file-like? thing)) (((? string? name) (? file-like? thing))
@ -1462,7 +1466,7 @@ error reporting."
(mlet* %store-monad ((system -> (bag-system bag)) (mlet* %store-monad ((system -> (bag-system bag))
(inputs -> (bag-transitive-inputs bag)) (inputs -> (bag-transitive-inputs bag))
(input-drvs (mapm %store-monad (input-drvs (mapm %store-monad
(cut expand-input context <>) (cut expand-input context <> system)
inputs)) inputs))
(paths -> (delete-duplicates (paths -> (delete-duplicates
(append-map (match-lambda (append-map (match-lambda
@ -1489,15 +1493,15 @@ This is an internal procedure."
(host -> (bag-transitive-host-inputs bag)) (host -> (bag-transitive-host-inputs bag))
(host-drvs (mapm %store-monad (host-drvs (mapm %store-monad
(cut expand-input context <> (cut expand-input context <>
#:target target) system #:target target)
host)) host))
(target* -> (bag-transitive-target-inputs bag)) (target* -> (bag-transitive-target-inputs bag))
(target-drvs (mapm %store-monad (target-drvs (mapm %store-monad
(cut expand-input context <>) (cut expand-input context <> system)
target*)) target*))
(build -> (bag-transitive-build-inputs bag)) (build -> (bag-transitive-build-inputs bag))
(build-drvs (mapm %store-monad (build-drvs (mapm %store-monad
(cut expand-input context <>) (cut expand-input context <> system)
build)) build))
(all -> (append build target* host)) (all -> (append build target* host))
(paths -> (delete-duplicates (paths -> (delete-duplicates

15
tests/packages.scm
View file

@ -717,6 +717,21 @@
(string=? (derivation-file-name (package-derivation %store p0)) (string=? (derivation-file-name (package-derivation %store p0))
(derivation-file-name (package-derivation %store p1))))) (derivation-file-name (package-derivation %store p1)))))
(test-assert "package-derivation, different system"
;; Make sure the 'system' argument of 'package-derivation' is respected.
(let* ((system (if (string=? (%current-system) "x86_64-linux")
"aarch64-linux"
"x86_64-linux"))
(drv (package-derivation %store (dummy-package "p")
system #:graft? #f)))
(define right-system?
(mlambdaq (drv)
(and (string=? (derivation-system drv) system)
(every (compose right-system? derivation-input-derivation)
(derivation-inputs drv)))))
(right-system? drv)))
(test-assert "package-output" (test-assert "package-output"
(let* ((package (dummy-package "p")) (let* ((package (dummy-package "p"))
(drv (package-derivation %store package))) (drv (package-derivation %store package)))