summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/packages/bootstrap.scm4
-rw-r--r--guix/build-system.scm18
-rw-r--r--guix/build-system/cmake.scm3
-rw-r--r--guix/build-system/gnu.scm3
-rw-r--r--guix/build-system/perl.scm4
-rw-r--r--guix/build-system/python.scm3
-rw-r--r--guix/build-system/ruby.scm3
-rw-r--r--guix/build-system/trivial.scm3
-rw-r--r--guix/packages.scm129
-rw-r--r--tests/packages.scm36
10 files changed, 137 insertions, 69 deletions
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index efa8cd89eb..315e8cf21e 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -198,9 +198,11 @@ $out/bin/guile --version~%"
#:inputs `((,bash) (,builder)))))
(define* (make-raw-bag name
- #:key source inputs native-inputs outputs target)
+ #:key source inputs native-inputs outputs
+ system target)
(bag
(name name)
+ (system system)
(build-inputs inputs)
(build raw-build)))
diff --git a/guix/build-system.scm b/guix/build-system.scm
index f185d5704f..4174972b98 100644
--- a/guix/build-system.scm
+++ b/guix/build-system.scm
@@ -28,6 +28,8 @@
bag
bag?
bag-name
+ bag-system
+ bag-target
bag-build-inputs
bag-host-inputs
bag-target-inputs
@@ -43,12 +45,19 @@
(description build-system-description) ; short description
(lower build-system-lower)) ; args ... -> bags
-;; "Bags" are low-level representations of "packages". Here we use
-;; build/host/target in the sense of the GNU tool chain (info "(autoconf)
-;; Specifying Target Triplets").
+;; "Bags" are low-level representations of "packages". The system and target
+;; of a bag is fixed when it's created. This is because build systems may
+;; choose inputs as a function of the system and target.
(define-record-type* <bag> bag %make-bag
bag?
(name bag-name) ;string
+
+ (system bag-system) ;string
+ (target bag-target ;string | #f
+ (default #f))
+
+ ;; Here we use build/host/target in the sense of the GNU tool chain (info
+ ;; "(autoconf) Specifying Target Triplets").
(build-inputs bag-build-inputs ;list of packages
(default '()))
(host-inputs bag-host-inputs ;list of packages
@@ -72,7 +81,7 @@
(define* (make-bag build-system name
#:key source (inputs '()) (native-inputs '())
(outputs '()) (arguments '())
- target)
+ system target)
"Ask BUILD-SYSTEM to return a 'bag' for NAME, with the given SOURCE,
INPUTS, NATIVE-INPUTS, OUTPUTS, and additional ARGUMENTS. If TARGET is not
#f, it must be a string with the GNU triplet of a cross-compilation target.
@@ -82,6 +91,7 @@ intermediate representation just above derivations."
(match build-system
(($ <build-system> _ description lower)
(apply lower name
+ #:system system
#:source source
#:inputs inputs
#:native-inputs native-inputs
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 0e750c0e11..85acc2d0b3 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -43,7 +43,7 @@
(module-ref module 'cmake)))
(define* (lower name
- #:key source inputs native-inputs outputs target
+ #:key source inputs native-inputs outputs system target
(cmake (default-cmake))
#:allow-other-keys
#:rest arguments)
@@ -54,6 +54,7 @@
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
+ (system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index c58dac10bb..d2c29d44b5 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -210,7 +210,7 @@ standard packages used as implicit inputs of the GNU build system."
(define* (lower name
#:key source inputs native-inputs outputs target
(implicit-inputs? #t) (implicit-cross-inputs? #t)
- (strip-binaries? #t)
+ (strip-binaries? #t) system
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME from the given arguments."
@@ -221,6 +221,7 @@ standard packages used as implicit inputs of the GNU build system."
(bag
(name name)
+ (system system) (target target)
(build-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 6cf8cbe13a..1a968f4150 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -43,7 +43,8 @@
(module-ref module 'perl)))
(define* (lower name
- #:key source inputs native-inputs outputs target
+ #:key source inputs native-inputs outputs
+ system target
(perl (default-perl))
#:allow-other-keys
#:rest arguments)
@@ -54,6 +55,7 @@
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
+ (system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index e28573bb05..3cd537c752 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -93,7 +93,7 @@ prepended to the name."
(cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
(define* (lower name
- #:key source inputs native-inputs outputs target
+ #:key source inputs native-inputs outputs system target
(python (default-python))
#:allow-other-keys
#:rest arguments)
@@ -104,6 +104,7 @@ prepended to the name."
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
+ (system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm
index 8312629fd8..e4e115f657 100644
--- a/guix/build-system/ruby.scm
+++ b/guix/build-system/ruby.scm
@@ -35,7 +35,7 @@
(module-ref ruby 'ruby)))
(define* (lower name
- #:key source inputs native-inputs outputs target
+ #:key source inputs native-inputs outputs system target
(ruby (default-ruby))
#:allow-other-keys
#:rest arguments)
@@ -46,6 +46,7 @@
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
+ (system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 1b07f14e63..839042aa2a 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -35,11 +35,12 @@
(package-derivation store guile system)))))
(define* (lower name
- #:key source inputs native-inputs outputs target
+ #:key source inputs native-inputs outputs system target
guile builder modules)
"Return a bag for NAME."
(bag
(name name)
+ (system system)
(host-inputs `(,@(if source
`(("source" ,source))
'())
diff --git a/guix/packages.scm b/guix/packages.scm
index 47cd6b95bb..a5b886a403 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -95,6 +95,7 @@
package-cross-build-system-error?
package->bag
+ bag->derivation
bag-transitive-inputs
bag-transitive-host-inputs
bag-transitive-build-inputs
@@ -629,6 +630,7 @@ and return it."
args inputs propagated-inputs native-inputs self-native-input?
outputs)
(or (make-bag build-system (package-full-name package)
+ #:system system
#:target target
#:source source
#:inputs (append (inputs)
@@ -647,6 +649,72 @@ and return it."
(&package-error
(package package))))))))))
+(define* (bag->derivation store bag
+ #:optional context)
+ "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
+a package object describing the context in which the call occurs, for improved
+error reporting."
+ (if (bag-target bag)
+ (bag->cross-derivation store bag)
+ (let* ((system (bag-system bag))
+ (inputs (bag-transitive-inputs bag))
+ (input-drvs (map (cut expand-input store context <> system)
+ inputs))
+ (paths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ inputs))))
+
+ (apply (bag-build bag)
+ store (bag-name bag) input-drvs
+ #:search-paths paths
+ #:outputs (bag-outputs bag) #:system system
+ (bag-arguments bag)))))
+
+(define* (bag->cross-derivation store bag
+ #:optional context)
+ "Return the derivation to build BAG, which is actually a cross build.
+Optionally, CONTEXT can be a package object denoting the context of the call.
+This is an internal procedure."
+ (let* ((system (bag-system bag))
+ (target (bag-target bag))
+ (host (bag-transitive-host-inputs bag))
+ (host-drvs (map (cut expand-input store context <> system target)
+ host))
+ (target* (bag-transitive-target-inputs bag))
+ (target-drvs (map (cut expand-input store context <> system)
+ target*))
+ (build (bag-transitive-build-inputs bag))
+ (build-drvs (map (cut expand-input store context <> system)
+ build))
+ (all (append build target* host))
+ (paths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-search-paths p))
+ (_ '()))
+ all)))
+ (npaths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ all))))
+
+ (apply (bag-build bag)
+ store (bag-name bag)
+ #:native-drvs build-drvs
+ #:target-drvs (append host-drvs target-drvs)
+ #:search-paths paths
+ #:native-search-paths npaths
+ #:outputs (bag-outputs bag)
+ #:system system #:target target
+ (bag-arguments bag))))
+
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the <derivation> object of PACKAGE for SYSTEM."
@@ -655,69 +723,16 @@ and return it."
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
(cached package system
- (let* ((bag (package->bag package system #f))
- (inputs (bag-transitive-inputs bag))
- (input-drvs (map (cut expand-input
- store package <> system)
- inputs))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- inputs))))
-
- (apply (bag-build bag)
- store (bag-name bag)
- input-drvs
- #:search-paths paths
- #:outputs (bag-outputs bag) #:system system
- (bag-arguments bag)))))
+ (bag->derivation store (package->bag package system #f)
+ package)))
(define* (package-cross-derivation store package target
#:optional (system (%current-system)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
(cached package (cons system target)
- (let* ((bag (package->bag package system target))
- (host (bag-transitive-host-inputs bag))
- (host-drvs (map (cut expand-input
- store package <>
- system target)
- host))
- (target* (bag-transitive-target-inputs bag))
- (target-drvs (map (cut expand-input
- store package <> system)
- target*))
- (build (bag-transitive-build-inputs bag))
- (build-drvs (map (cut expand-input
- store package <> system)
- build))
- (all (append build target* host))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-search-paths p))
- (_ '()))
- all)))
- (npaths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- all))))
-
- (apply (bag-build bag)
- store (bag-name bag)
- #:native-drvs build-drvs
- #:target-drvs (append host-drvs target-drvs)
- #:search-paths paths
- #:native-search-paths npaths
- #:outputs (bag-outputs bag)
- #:system system #:target target
- (bag-arguments bag)))))
+ (bag->derivation store (package->bag package system target)
+ package)))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))
diff --git a/tests/packages.scm b/tests/packages.scm
index 6deb21c331..2a87f3f15d 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -281,9 +281,11 @@
(s (build-system
(name 'raw)
(description "Raw build system with direct store access")
- (lower (lambda* (name #:key source inputs #:allow-other-keys)
+ (lower (lambda* (name #:key source inputs system target
+ #:allow-other-keys)
(bag
(name name)
+ (system system) (target target)
(build-inputs inputs)
(build
(lambda* (store name inputs
@@ -339,6 +341,38 @@
(package-cross-derivation %store p "mips64el-linux-gnu")
#f)))
+(test-equal "package->bag"
+ `("foo86-hurd" #f (,(package-source gnu-make))
+ (,(canonical-package glibc)) (,(canonical-package coreutils)))
+ (let ((bag (package->bag gnu-make "foo86-hurd")))
+ (list (bag-system bag) (bag-target bag)
+ (assoc-ref (bag-build-inputs bag) "source")
+ (assoc-ref (bag-build-inputs bag) "libc")
+ (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-equal "package->bag, cross-compilation"
+ `(,(%current-system) "foo86-hurd"
+ (,(package-source gnu-make))
+ (,(canonical-package glibc)) (,(canonical-package coreutils)))
+ (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
+ (list (bag-system bag) (bag-target bag)
+ (assoc-ref (bag-build-inputs bag) "source")
+ (assoc-ref (bag-build-inputs bag) "libc")
+ (assoc-ref (bag-build-inputs bag) "coreutils"))))
+
+(test-assert "bag->derivation"
+ (let ((bag (package->bag gnu-make))
+ (drv (package-derivation %store gnu-make)))
+ (parameterize ((%current-system "foox86-hurd")) ;should have no effect
+ (equal? drv (bag->derivation %store bag)))))
+
+(test-assert "bag->derivation, cross-compilation"
+ (let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu"))
+ (drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu")))
+ (parameterize ((%current-system "foox86-hurd") ;should have no effect
+ (%current-target-system "foo64-linux-gnu"))
+ (equal? drv (bag->derivation %store bag)))))
+
(unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
(test-skip 1))
(test-assert "GNU Make, bootstrap"
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-07 21:39:32 +0000