build-system: Bags record their system and target.
* guix/build-system.scm (<bag>)[system, target]: New fields.
(make-bag): Add #:system parameter and pass it to LOWER.
* gnu/packages/bootstrap.scm (make-raw-bag): Initialize 'system' field.
* guix/build-system/cmake.scm (lower): Likewise.
* guix/build-system/perl.scm (lower): Likewise.
* guix/build-system/python.scm (lower): Likewise.
* guix/build-system/ruby.scm (lower): Likewise.
* guix/build-system/trivial.scm (lower): Likewise.
* guix/build-system/gnu.scm (lower): Initialize 'system' and 'target'
fields.
* guix/packages.scm (bag->derivation, bag->cross-derivation): New
procedures.
(package-derivation, package-cross-derivation): Use 'bag->derivation'.
* tests/packages.scm ("search paths"): Initialize 'system' and 'target'
fields.
("package->bag", "package->bag, cross-compilation", "bag->derivation",
"bag->derivation, cross-compilation"): New tests.
master
Ludovic Courtès
parent
b4469d8c12
commit
d3d337d2d8
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
'())
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue