[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: packages: 'package-derivation' honors 'system' again.
From: |
guix-commits |
Subject: |
02/02: packages: 'package-derivation' honors 'system' again. |
Date: |
Thu, 1 Jul 2021 15:39:20 -0400 (EDT) |
civodul pushed a commit to branch core-updates
in repository guix.
commit 98c075c24e26798ef52ab66641faa7b0aa87726b
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jul 1 21:30:46 2021 +0200
packages: 'package-derivation' honors 'system' again.
Fixes a regression introduced in
7d873f194ca69d6096d28d7a224ab78e83e34fe1.
Starting from 7d873f194ca69d6096d28d7a224ab78e83e34fe1, 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.
---
guix/packages.scm | 22 +++++++++++++---------
tests/packages.scm | 15 +++++++++++++++
2 files changed, 28 insertions(+), 9 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index a66dbea..3ba61b4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -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
diff --git a/tests/packages.scm b/tests/packages.scm
index 47d10af..47fc34d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -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)))