me
/
guix
Archived
1
0
Fork 0
Code

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

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.
master
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
(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
only used to provide contextual information in exceptions."
(with-monad %store-monad
@ -1224,15 +1224,19 @@ only used to provide contextual information in exceptions."
;; derivation.
(((? string? name) (? package? package))
(mlet %store-monad ((drv (if target
(package->cross-derivation package target
(package->cross-derivation package
target system
#:graft? #f)
(package->derivation package #:graft? #f))))
(package->derivation package system
#:graft? #f))))
(return (list name (gexp-input drv #:native? (not target))))))
(((? string? name) (? package? package) (? string? output))
(mlet %store-monad ((drv (if target
(package->cross-derivation package target
(package->cross-derivation package
target system
#:graft? #f)
(package->derivation package #:graft? #f))))
(package->derivation package system
#:graft? #f))))
(return (list name (gexp-input drv output #:native? (not target))))))
(((? string? name) (? file-like? thing))
@ -1462,7 +1466,7 @@ error reporting."
(mlet* %store-monad ((system -> (bag-system bag))
(inputs -> (bag-transitive-inputs bag))
(input-drvs (mapm %store-monad
(cut expand-input context <>)
(cut expand-input context <> system)
inputs))
(paths -> (delete-duplicates
(append-map (match-lambda
@ -1489,15 +1493,15 @@ This is an internal procedure."
(host -> (bag-transitive-host-inputs bag))
(host-drvs (mapm %store-monad
(cut expand-input context <>
#:target target)
system #:target target)
host))
(target* -> (bag-transitive-target-inputs bag))
(target-drvs (mapm %store-monad
(cut expand-input context <>)
(cut expand-input context <> system)
target*))
(build -> (bag-transitive-build-inputs bag))
(build-drvs (mapm %store-monad
(cut expand-input context <>)
(cut expand-input context <> system)
build))
(all -> (append build target* host))
(paths -> (delete-duplicates

15
tests/packages.scm
View File

@ -717,6 +717,21 @@
(string=? (derivation-file-name (package-derivation %store p0))
(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"
(let* ((package (dummy-package "p"))
(drv (package-derivation %store package)))