nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2014-10-05 16:32:25 +02:00
parent b4469d8c12
commit d3d337d2d8
10 changed files with 137 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gnu/packages/bootstrap.scm
View File

@ -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)))

18
guix/build-system.scm
View File

@ -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

3
guix/build-system/cmake.scm
View File

@ -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))
'())

3
guix/build-system/gnu.scm
View File

@ -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))
'())

4
guix/build-system/perl.scm
View File

@ -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))
'())

3
guix/build-system/python.scm
View File

@ -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))
'())

3
guix/build-system/ruby.scm
View File

@ -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))
'())

3
guix/build-system/trivial.scm
View File

@ -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))
'())

69
guix/packages.scm
View File

@ -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,18 +649,16 @@ and return it."
(&package-error
(package package))))))))))
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; 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))
(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 package <> system)
(input-drvs (map (cut expand-input store context <> system)
inputs))
(paths (delete-duplicates
(append-map (match-lambda
@ -669,30 +669,26 @@ and return it."
inputs))))
(apply (bag-build bag)
store (bag-name bag)
input-drvs
store (bag-name bag) input-drvs
#:search-paths paths
#:outputs (bag-outputs bag) #:system system
(bag-arguments bag)))))
(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))
(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 package <>
system target)
(host-drvs (map (cut expand-input store context <> system target)
host))
(target* (bag-transitive-target-inputs bag))
(target-drvs (map (cut expand-input
store package <> system)
(target-drvs (map (cut expand-input store context <> system)
target*))
(build (bag-transitive-build-inputs bag))
(build-drvs (map (cut expand-input
store package <> system)
(build-drvs (map (cut expand-input store context <> system)
build))
(all (append build target* host))
(paths (delete-duplicates
@ -717,7 +713,26 @@ system identifying string)."
#:native-search-paths npaths
#:outputs (bag-outputs bag)
#:system system #:target target
(bag-arguments bag)))))
(bag-arguments bag))))
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
;; 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
(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)
(bag->derivation store (package->bag package system target)
package)))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))

36
tests/packages.scm
View File

@ -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"