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

build-system: Introduce "bags" as an intermediate representation. 

* guix/build-system.scm (<build-system>)[build, cross-build]: Remove.
  [lower]: New field.
  (<bag>): New record type.
  (make-bag): New procedure.
* guix/packages.scm (bag-transitive-inputs, bag-transitive-build-inputs,
  bag-transitive-host-inputs, bag-transitive-target-inputs,
  package->bag): New procedures.
  (package-derivation): Use it; use the bag, apply its build procedure,
  etc.
  (package-cross-derivation): Likewise.
* gnu/packages/bootstrap.scm (raw-build, make-raw-bag): New procedure.
  (%bootstrap-guile): Use them.
* guix/build-system/trivial.scm (lower): New procedure.
  (trivial-build, trivial-cross-build): Remove 'source' parameter.  Pass
  INPUTS as is.
  (trivial-build-system): Adjust accordingly.
* guix/build-system/gnu.scm (%store, inputs-search-paths,
  standard-search-paths, expand-inputs, standard-inputs): Remove.
  (gnu-lower): New procedure.
  (gnu-build): Remove 'source' and #:implicit-inputs? parameters.
  Remove 'implicit-inputs' and 'implicit-search-paths' variables.  Get
  the source from INPUT-DRVS.
  (gnu-cross-build): Likewise.
  (standard-cross-packages): Remove call to 'standard-packages'.
  (standard-cross-inputs, standard-cross-search-paths): Remove.
  (gnu-build-system): Remove 'build' and 'cross-build'; add 'lower'.
* guix/build-system/cmake.scm (lower): New procedure.
  (cmake-build): Remove 'source' and #:cmake parameters.  Use INPUTS and
  SEARCH-PATHS as is.  Get the source from INPUTS.
* guix/build-system/perl.scm: Likewise.
* guix/build-system/python.scm: Likewise.
* guix/build-system/ruby.scm: Likewise.
* gnu/packages/cross-base.scm (cross-gcc): Change "cross-linux-headers"
  to "linux-headers".
  (cross-libc)[xlinux-headers]: Pass #:implicit-cross-inputs? #f.
  Likewise.  In 'propagated-inputs', change "cross-linux-headers" to
  "linux-headers".
* guix/git-download.scm (git-fetch): Use 'standard-packages' instead of
  'standard-inputs'.
* tests/builders.scm ("gnu-build-system"): Remove use of
  'build-system-builder'.
  ("gnu-build"): Remove 'source' and #:implicit-inputs? arguments to
  'gnu-build'.
* tests/packages.scm ("search paths"): Adjust to new build system API.
  ("package-cross-derivation, no cross builder"): Likewise.
* doc/guix.texi (Build Systems): Add paragraph on bags.
This commit is contained in:
Ludovic Courtès 2014-10-03 18:06:16 +02:00
parent 2348fd0f51
commit 0d5a559f0f
15 changed files with 561 additions and 449 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.dir-locals.el
View File

@ -17,6 +17,8 @@
(eval . (put 'with-directory-excursion 'scheme-indent-function 1)) (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
(eval . (put 'package 'scheme-indent-function 0)) (eval . (put 'package 'scheme-indent-function 0))
(eval . (put 'origin 'scheme-indent-function 0)) (eval . (put 'origin 'scheme-indent-function 0))
(eval . (put 'build-system 'scheme-indent-function 0))
(eval . (put 'bag 'scheme-indent-function 0))
(eval . (put 'operating-system 'scheme-indent-function 0)) (eval . (put 'operating-system 'scheme-indent-function 0))
(eval . (put 'file-system 'scheme-indent-function 0)) (eval . (put 'file-system 'scheme-indent-function 0))
(eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-entry 'scheme-indent-function 0))

7
doc/guix.texi
View File

@ -1519,6 +1519,13 @@ Build systems are @code{<build-system>} objects. The interface to
create and manipulate them is provided by the @code{(guix build-system)} create and manipulate them is provided by the @code{(guix build-system)}
module, and actual build systems are exported by specific modules. module, and actual build systems are exported by specific modules.
Under the hood, build systems first compile package objects to
@dfn{bags}. A @dfn{bag} is like a package, but with less
ornamentation---in other words, a bag is a lower-level representation of
a package, which includes all the inputs of that package, including some
that were implicitly added by the build system. This intermediate
representation is then compiled to a derivation (@pxref{Derivations}).
Build systems accept an optional list of @dfn{arguments}. In package Build systems accept an optional list of @dfn{arguments}. In package
definitions, these are passed @i{via} the @code{arguments} field definitions, these are passed @i{via} the @code{arguments} field
(@pxref{Defining Packages}). They are typically keyword arguments (@pxref{Defining Packages}). They are typically keyword arguments

76
gnu/packages/bootstrap.scm
View File

@ -164,6 +164,46 @@ check whether everything is alright."
;;; Bootstrap packages. ;;; Bootstrap packages.
;;; ;;;
(define* (raw-build store name inputs
#:key outputs system search-paths
#:allow-other-keys)
(define (->store file)
(add-to-store store file #t "sha256"
(or (search-bootstrap-binary file
system)
(error "bootstrap binary not found"
file system))))
(let* ((tar (->store "tar"))
(xz (->store "xz"))
(mkdir (->store "mkdir"))
(bash (->store "bash"))
(guile (->store "guile-2.0.9.tar.xz"))
(builder
(add-text-to-store store
"build-bootstrap-guile.sh"
(format #f "
echo \"unpacking bootstrap Guile to '$out'...\"
~a $out
cd $out
~a -dc < ~a | ~a xv
# Sanity check.
$out/bin/guile --version~%"
mkdir xz guile tar)
(list mkdir xz guile tar))))
(derivation store name
bash `(,builder)
#:system system
#:inputs `((,bash) (,builder)))))
(define* (make-raw-bag name
#:key source inputs native-inputs outputs target)
(bag
(name name)
(build-inputs inputs)
(build raw-build)))
(define %bootstrap-guile (define %bootstrap-guile
;; The Guile used to run the build scripts of the initial derivations. ;; The Guile used to run the build scripts of the initial derivations.
;; It is just unpacked from a tarball containing a pre-built binary. ;; It is just unpacked from a tarball containing a pre-built binary.
@ -172,39 +212,9 @@ check whether everything is alright."
;; XXX: Would need libc's `libnss_files2.so' for proper `getaddrinfo' ;; XXX: Would need libc's `libnss_files2.so' for proper `getaddrinfo'
;; support (for /etc/services). ;; support (for /etc/services).
(let ((raw (build-system (let ((raw (build-system
(name "raw") (name 'raw)
(description "Raw build system with direct store access") (description "Raw build system with direct store access")
(build (lambda* (store name source inputs (lower make-raw-bag))))
#:key outputs system search-paths)
(define (->store file)
(add-to-store store file #t "sha256"
(or (search-bootstrap-binary file
system)
(error "bootstrap binary not found"
file system))))
(let* ((tar (->store "tar"))
(xz (->store "xz"))
(mkdir (->store "mkdir"))
(bash (->store "bash"))
(guile (->store "guile-2.0.9.tar.xz"))
(builder
(add-text-to-store store
"build-bootstrap-guile.sh"
(format #f "
echo \"unpacking bootstrap Guile to '$out'...\"
~a $out
cd $out
~a -dc < ~a | ~a xv
# Sanity check.
$out/bin/guile --version~%"
mkdir xz guile tar)
(list mkdir xz guile tar))))
(derivation store name
bash `(,builder)
#:system system
#:inputs `((,bash) (,builder)))))))))
(package (package
(name "guile-bootstrap") (name "guile-bootstrap")
(version "2.0") (version "2.0")

22
gnu/packages/cross-base.scm
View File

@ -154,7 +154,7 @@ GCC that does not target a libc; otherwise, target that libc."
;; them from CPATH. ;; them from CPATH.
(let ((libc (assoc-ref inputs "libc")) (let ((libc (assoc-ref inputs "libc"))
(linux (assoc-ref inputs (linux (assoc-ref inputs
"libc/cross-linux-headers"))) "libc/linux-headers")))
(define (cross? x) (define (cross? x)
;; Return #t if X is a cross-libc or cross Linux. ;; Return #t if X is a cross-libc or cross Linux.
(or (string-prefix? libc x) (or (string-prefix? libc x)
@ -224,7 +224,9 @@ XBINUTILS and the cross tool chain."
(name (string-append (package-name linux-libre-headers) (name (string-append (package-name linux-libre-headers)
"-cross-" target)) "-cross-" target))
(arguments (arguments
(substitute-keyword-arguments (package-arguments linux-libre-headers) (substitute-keyword-arguments
`(#:implicit-cross-inputs? #f
,@(package-arguments linux-libre-headers))
((#:phases phases) ((#:phases phases)
`(alist-replace `(alist-replace
'build 'build
@ -243,7 +245,14 @@ XBINUTILS and the cross tool chain."
(name (string-append "glibc-cross-" target)) (name (string-append "glibc-cross-" target))
(arguments (arguments
(substitute-keyword-arguments (substitute-keyword-arguments
`(#:strip-binaries? #f ; disable stripping (see above) `(;; Disable stripping (see above.)
#:strip-binaries? #f
;; This package is used as a target input, but it should not have
;; the usual cross-compilation inputs since that would include
;; itself.
#:implicit-cross-inputs? #f
,@(package-arguments glibc)) ,@(package-arguments glibc))
((#:configure-flags flags) ((#:configure-flags flags)
`(cons ,(string-append "--host=" target) `(cons ,(string-append "--host=" target)
@ -252,13 +261,16 @@ XBINUTILS and the cross tool chain."
`(alist-cons-before `(alist-cons-before
'configure 'set-cross-linux-headers-path 'configure 'set-cross-linux-headers-path
(lambda* (#:key inputs #:allow-other-keys) (lambda* (#:key inputs #:allow-other-keys)
(let ((linux (assoc-ref inputs "cross-linux-headers"))) (let ((linux (assoc-ref inputs "linux-headers")))
(setenv "CROSS_CPATH" (setenv "CROSS_CPATH"
(string-append linux "/include")) (string-append linux "/include"))
#t)) #t))
,phases)))) ,phases))))
(propagated-inputs `(("cross-linux-headers" ,xlinux-headers))) ;; Shadow the native "linux-headers" because glibc's recipe expect the
;; "linux-headers" input to point to the right thing.
(propagated-inputs `(("linux-headers" ,xlinux-headers)))
(native-inputs `(("cross-gcc" ,xgcc) (native-inputs `(("cross-gcc" ,xgcc)
("cross-binutils" ,xbinutils) ("cross-binutils" ,xbinutils)
,@(package-native-inputs glibc))))) ,@(package-native-inputs glibc)))))

68
guix/build-system.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,17 +18,73 @@
(define-module (guix build-system) (define-module (guix build-system)
#:use-module (guix records) #:use-module (guix records)
#:use-module (ice-9 match)
#:export (build-system #:export (build-system
build-system? build-system?
build-system-name build-system-name
build-system-description build-system-description
build-system-builder build-system-lower
build-system-cross-builder))
bag
bag?
bag-name
bag-build-inputs
bag-host-inputs
bag-target-inputs
bag-outputs
bag-arguments
bag-build
make-bag))
(define-record-type* <build-system> build-system make-build-system (define-record-type* <build-system> build-system make-build-system
build-system? build-system?
(name build-system-name) ; symbol (name build-system-name) ; symbol
(description build-system-description) ; short description (description build-system-description) ; short description
(build build-system-builder) ; (store system name source inputs) (lower build-system-lower)) ; args ... -> bags
(cross-build build-system-cross-builder ; (store system x-system ...)
(default #f))) ;; "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").
(define-record-type* <bag> bag %make-bag
bag?
(name bag-name) ;string
(build-inputs bag-build-inputs ;list of packages
(default '()))
(host-inputs bag-host-inputs ;list of packages
(default '()))
;; "Target inputs" are packages that are built natively, but that are used
;; by target programs in a cross-compilation environment. Thus, they act
;; like 'inputs' as far as search paths are concerned. The only example of
;; that is the cross-libc: it is an input of 'cross-gcc', thus built
;; natively; yet, we want it to be considered as a target input for the
;; purposes of $CPATH, $LIBRARY_PATH, etc.
(target-inputs bag-target-inputs
(default '()))
(outputs bag-outputs ;list of strings
(default '("out")))
(arguments bag-arguments ;list
(default '()))
(build bag-build)) ;bag -> derivation
(define* (make-bag build-system name
#:key source (inputs '()) (native-inputs '())
(outputs '()) (arguments '())
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.
This is the mechanism by which a package is \"lowered\" to a bag, which is the
intermediate representation just above derivations."
(match build-system
(($ <build-system> _ description lower)
(apply lower name
#:source source
#:inputs inputs
#:native-inputs native-inputs
#:outputs outputs
#:target target
arguments))))

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

@ -42,44 +42,71 @@
(let ((module (resolve-interface '(gnu packages cmake)))) (let ((module (resolve-interface '(gnu packages cmake))))
(module-ref module 'cmake))) (module-ref module 'cmake)))
(define* (cmake-build store name source inputs (define* (lower name
#:key (guile #f) #:key source inputs native-inputs outputs target
(outputs '("out")) (configure-flags ''()) (cmake (default-cmake))
(search-paths '()) #:allow-other-keys
(make-flags ''()) #:rest arguments)
(cmake (default-cmake)) "Return a bag for NAME."
(out-of-source? #t) (define private-keywords
(build-type "RelWithDebInfo") '(#:source #:target #:cmake #:inputs #:native-inputs))
(tests? #t)
(test-target "test") (and (not target) ;XXX: no cross-compilation
(parallel-build? #t) (parallel-tests? #f) (bag
(patch-shebangs? #t) (name name)
(strip-binaries? #t) (host-inputs `(,@(if source
(strip-flags ''("--strip-debug")) `(("source" ,source))
(strip-directories ''("lib" "lib64" "libexec" '())
"bin" "sbin")) ,@inputs
(phases '(@ (guix build cmake-build-system)
%standard-phases)) ;; Keep the standard inputs of 'gnu-build-system'.
(system (%current-system)) ,@(standard-packages)))
(imported-modules '((guix build cmake-build-system) (build-inputs `(("cmake" ,cmake)
(guix build gnu-build-system) ,@native-inputs))
(guix build utils))) (outputs outputs)
(modules '((guix build cmake-build-system) (build cmake-build)
(guix build utils)))) (arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (cmake-build store name inputs
#:key (guile #f)
(outputs '("out")) (configure-flags ''())
(search-paths '())
(make-flags ''())
(out-of-source? #t)
(build-type "RelWithDebInfo")
(tests? #t)
(test-target "test")
(parallel-build? #t) (parallel-tests? #f)
(patch-shebangs? #t)
(strip-binaries? #t)
(strip-flags ''("--strip-debug"))
(strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin"))
(phases '(@ (guix build cmake-build-system)
%standard-phases))
(system (%current-system))
(imported-modules '((guix build cmake-build-system)
(guix build gnu-build-system)
(guix build utils)))
(modules '((guix build cmake-build-system)
(guix build utils))))
"Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE
provides a 'CMakeLists.txt' file as its build system." provides a 'CMakeLists.txt' file as its build system."
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(cmake-build #:source ,(if (derivation? source) (cmake-build #:source ,(match (assoc-ref inputs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:system ,system #:system ,system
#:outputs %outputs #:outputs %outputs
#:inputs %build-inputs #:inputs %build-inputs
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append search-paths search-paths)
(standard-search-paths)))
#:phases ,phases #:phases ,phases
#:configure-flags ,configure-flags #:configure-flags ,configure-flags
#:make-flags ,make-flags #:make-flags ,make-flags
@ -103,27 +130,17 @@ provides a 'CMakeLists.txt' file as its build system."
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system)))))
(let ((cmake (package-derivation store cmake system))) (build-expression->derivation store name builder
(build-expression->derivation store name builder #:system system
#:system system #:inputs inputs
#:inputs #:modules imported-modules
`(,@(if source #:outputs outputs
`(("source" ,source)) #:guile-for-build guile-for-build))
'())
("cmake" ,cmake)
,@inputs
;; Keep the standard inputs of
;; `gnu-build-system'.
,@(standard-inputs system))
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build)))
(define cmake-build-system (define cmake-build-system
(build-system (name 'cmake) (build-system
(description "The standard CMake build system") (name 'cmake)
(build cmake-build))) (description "The standard CMake build system")
(lower lower)))
;;; cmake.scm ends here ;;; cmake.scm ends here

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

@ -23,12 +23,10 @@
#:use-module (guix build-system) #:use-module (guix build-system)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-39)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (gnu-build #:export (gnu-build
gnu-build-system gnu-build-system
standard-search-paths standard-packages
standard-inputs
package-with-explicit-inputs package-with-explicit-inputs
package-with-extra-configure-variable package-with-extra-configure-variable
static-libgcc-package static-libgcc-package
@ -201,10 +199,6 @@ listed in REFS."
p)) p))
(define %store
;; Store passed to STANDARD-INPUTS.
(make-parameter #f))
(define (standard-packages) (define (standard-packages)
"Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of "Return the list of (NAME PACKAGE OUTPUT) or (NAME PACKAGE) tuples of
standard packages used as implicit inputs of the GNU build system." standard packages used as implicit inputs of the GNU build system."
@ -213,53 +207,47 @@ standard packages used as implicit inputs of the GNU build system."
(let ((distro (resolve-module '(gnu packages commencement)))) (let ((distro (resolve-module '(gnu packages commencement))))
(module-ref distro '%final-inputs))) (module-ref distro '%final-inputs)))
(define* (inputs-search-paths inputs (define* (lower name
#:optional (package->search-paths #:key source inputs native-inputs outputs target
package-native-search-paths)) (implicit-inputs? #t) (implicit-cross-inputs? #t)
"Return the <search-path-specification> objects for INPUTS, using (strip-binaries? #t)
PACKAGE->SEARCH-PATHS to extract the search path specifications of a package." #:allow-other-keys
(append-map (match-lambda #:rest arguments)
((_ (? package? p) _ ...) "Return a bag for NAME from the given arguments."
(package->search-paths p)) (define private-keywords
(_ `(#:source #:inputs #:native-inputs #:outputs
'())) #:implicit-inputs? #:implicit-cross-inputs?
inputs)) ,@(if target '() '(#:target))))
(define (standard-search-paths) (bag
"Return the list of <search-path-specification> for the standard (implicit) (name name)
inputs when doing a native build." (build-inputs `(,@(if source
(inputs-search-paths (standard-packages))) `(("source" ,source))
'())
,@native-inputs
,@(if (and target implicit-cross-inputs?)
(standard-cross-packages target 'host)
'())
,@(if implicit-inputs?
(standard-packages)
'())))
(host-inputs inputs)
(define (expand-inputs inputs system) ;; The cross-libc is really a target package, but for bootstrapping
"Expand INPUTS, which contains <package> objects, so that it contains only ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a
derivations for SYSTEM. Include propagated inputs in the result." ;; native package, so it would end up using a "native" variant of
(define input-package->derivation ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
(match-lambda ;; would use a target variant (built with 'gnu-cross-build'.)
((name pkg sub-drv ...) (target-inputs (if (and target implicit-cross-inputs?)
(cons* name (package-derivation (%store) pkg system) sub-drv)) (standard-cross-packages target 'target)
((name (? derivation-path? path) sub-drv ...) '()))
(cons* name path sub-drv)) (outputs (if strip-binaries?
(z outputs
(error "invalid standard input" z)))) (delete "debug" outputs)))
(build (if target gnu-cross-build gnu-build))
(arguments (strip-keyword-arguments private-keywords arguments))))
(map input-package->derivation (define* (gnu-build store name input-drvs
(append inputs
(append-map (match-lambda
((name package _ ...)
(package-transitive-propagated-inputs package)))
inputs))))
(define standard-inputs
;; FIXME: Memoization should be associated with the open store (as for
;; 'add-text-to-store'), otherwise we get .drv that may not be valid when
;; switching to another store.
(memoize
(lambda (system)
"Return the list of implicit standard inputs used with the GNU Build
System: GCC, GNU Make, Bash, Coreutils, etc."
(expand-inputs (standard-packages) system))))
(define* (gnu-build store name source inputs
#:key (guile #f) #:key (guile #f)
(outputs '("out")) (outputs '("out"))
(search-paths '()) (search-paths '())
@ -277,7 +265,6 @@ System: GCC, GNU Make, Bash, Coreutils, etc."
"bin" "sbin")) "bin" "sbin"))
(phases '%standard-phases) (phases '%standard-phases)
(system (%current-system)) (system (%current-system))
(implicit-inputs? #t) ; useful when bootstrapping
(imported-modules %default-modules) (imported-modules %default-modules)
(modules %default-modules) (modules %default-modules)
allowed-references) allowed-references)
@ -295,16 +282,6 @@ which could lead to gratuitous input divergence.
ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs
are allowed to refer to." are allowed to refer to."
(define implicit-inputs
(and implicit-inputs?
(parameterize ((%store store))
(standard-inputs system))))
(define implicit-search-paths
(if implicit-inputs?
(standard-search-paths)
'()))
(define canonicalize-reference (define canonicalize-reference
(match-lambda (match-lambda
((? package? p) ((? package? p)
@ -318,15 +295,18 @@ are allowed to refer to."
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(gnu-build #:source ,(if (derivation? source) (gnu-build #:source ,(match (assoc-ref input-drvs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:system ,system #:system ,system
#:outputs %outputs #:outputs %outputs
#:inputs %build-inputs #:inputs %build-inputs
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append implicit-search-paths search-paths)
search-paths))
#:phases ,phases #:phases ,phases
#:configure-flags ,configure-flags #:configure-flags ,configure-flags
#:make-flags ,make-flags #:make-flags ,make-flags
@ -351,17 +331,8 @@ are allowed to refer to."
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system
#:inputs #:inputs input-drvs
`(,@(if source #:outputs outputs
`(("source" ,source))
'())
,@inputs
,@(if implicit-inputs?
implicit-inputs
'()))
#:outputs (if strip-binaries?
outputs
(delete "debug" outputs))
#:modules imported-modules #:modules imported-modules
#:allowed-references #:allowed-references
(and allowed-references (and allowed-references
@ -388,30 +359,15 @@ is one of `host' or `target'."
`(("cross-gcc" ,(gcc target `(("cross-gcc" ,(gcc target
(binutils target) (binutils target)
(libc target))) (libc target)))
("cross-binutils" ,(binutils target)) ("cross-binutils" ,(binutils target))))
,@(standard-packages)))
((target) ((target)
`(("cross-libc" ,(libc target))))))))) `(("cross-libc" ,(libc target)))))))))
(define standard-cross-inputs (define* (gnu-cross-build store name
(memoize
(lambda (system target kind)
"Return the list of implicit standard inputs used with the GNU Build
System when cross-compiling for TARGET: GCC, GNU Make, Bash, Coreutils, etc."
(expand-inputs (standard-cross-packages target kind) system))))
(define (standard-cross-search-paths target kind)
"Return the list of <search-path-specification> for the standard (implicit)
inputs."
(inputs-search-paths (append (standard-cross-packages target 'target)
(standard-cross-packages target 'host))
(case kind
((host) package-native-search-paths)
((target) package-search-paths))))
(define* (gnu-cross-build store name target source inputs native-inputs
#:key #:key
target native-drvs target-drvs
(guile #f) (guile #f)
source
(outputs '("out")) (outputs '("out"))
(search-paths '()) (search-paths '())
(native-search-paths '()) (native-search-paths '())
@ -429,7 +385,6 @@ inputs."
"bin" "sbin")) "bin" "sbin"))
(phases '%standard-phases) (phases '%standard-phases)
(system (%current-system)) (system (%current-system))
(implicit-inputs? #t)
(imported-modules '((guix build gnu-build-system) (imported-modules '((guix build gnu-build-system)
(guix build utils))) (guix build utils)))
(modules '((guix build gnu-build-system) (modules '((guix build gnu-build-system)
@ -438,27 +393,6 @@ inputs."
"Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are
cross-built inputs, and NATIVE-INPUTS are inputs that run on the build cross-built inputs, and NATIVE-INPUTS are inputs that run on the build
platform." platform."
(define implicit-host-inputs
(and implicit-inputs?
(parameterize ((%store store))
(standard-cross-inputs system target 'host))))
(define implicit-target-inputs
(and implicit-inputs?
(parameterize ((%store store))
(standard-cross-inputs system target 'target))))
(define implicit-host-search-paths
(if implicit-inputs?
(standard-cross-search-paths target 'host)
'()))
(define implicit-target-search-paths
(if implicit-inputs?
(standard-cross-search-paths target 'target)
'()))
(define canonicalize-reference (define canonicalize-reference
(match-lambda (match-lambda
((? package? p) ((? package? p)
@ -478,39 +412,39 @@ platform."
',(map (match-lambda ',(map (match-lambda
((name (? derivation? drv) sub ...) ((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub))) `(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...)
`(,name . ,(apply derivation-path->output-path
drv-path sub)))
((name path) ((name path)
`(,name . ,path))) `(,name . ,path)))
(append (or implicit-host-inputs '()) native-inputs))) native-drvs))
(define %build-target-inputs (define %build-target-inputs
',(map (match-lambda ',(map (match-lambda
((name (? derivation? drv) sub ...) ((name (? derivation? drv) sub ...)
`(,name . ,(apply derivation->output-path drv sub))) `(,name . ,(apply derivation->output-path drv sub)))
((name (? derivation-path? drv-path) sub ...) ((name (? package? pkg) sub ...)
`(,name . ,(apply derivation-path->output-path (let ((drv (package-cross-derivation store pkg
drv-path sub))) target system)))
`(,name . ,(apply derivation->output-path drv sub))))
((name path) ((name path)
`(,name . ,path))) `(,name . ,path)))
(append (or implicit-target-inputs '()) inputs))) target-drvs))
(gnu-build #:source ,(if (derivation? source) (gnu-build #:source ,(match (assoc-ref native-drvs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:system ,system #:system ,system
#:target ,target #:target ,target
#:outputs %outputs #:outputs %outputs
#:inputs %build-target-inputs #:inputs %build-target-inputs
#:native-inputs %build-host-inputs #:native-inputs %build-host-inputs
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append implicit-target-search-paths search-paths)
search-paths))
#:native-search-paths ',(map #:native-search-paths ',(map
search-path-specification->sexp search-path-specification->sexp
(append implicit-host-search-paths native-search-paths)
native-search-paths))
#:phases ,phases #:phases ,phases
#:configure-flags ,configure-flags #:configure-flags ,configure-flags
#:make-flags ,make-flags #:make-flags ,make-flags
@ -535,21 +469,8 @@ platform."
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:system system #:system system
#:inputs #:inputs (append native-drvs target-drvs)
`(,@(if source #:outputs outputs
`(("source" ,source))
'())
,@inputs
,@(if implicit-inputs?
implicit-target-inputs
'())
,@native-inputs
,@(if implicit-inputs?
implicit-host-inputs
'()))
#:outputs (if strip-binaries?
outputs
(delete "debug" outputs))
#:modules imported-modules #:modules imported-modules
#:allowed-references #:allowed-references
(and allowed-references (and allowed-references
@ -558,8 +479,8 @@ platform."
#:guile-for-build guile-for-build)) #:guile-for-build guile-for-build))
(define gnu-build-system (define gnu-build-system
(build-system (name 'gnu) (build-system
(description (name 'gnu)
"The GNU Build System—i.e., ./configure && make && make install") (description
(build gnu-build) "The GNU Build System—i.e., ./configure && make && make install")
(cross-build gnu-cross-build))) (lower lower)))

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

@ -42,9 +42,33 @@
(let ((module (resolve-interface '(gnu packages perl)))) (let ((module (resolve-interface '(gnu packages perl))))
(module-ref module 'perl))) (module-ref module 'perl)))
(define* (perl-build store name source inputs (define* (lower name
#:key source inputs native-inputs outputs target
(perl (default-perl))
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
'(#:source #:target #:perl #:inputs #:native-inputs))
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs
;; Keep the standard inputs of 'gnu-build-system'.
,@(standard-packages)))
(build-inputs `(("perl" ,perl)
,@native-inputs))
(outputs outputs)
(build perl-build)
(arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (perl-build store name inputs
#:key #:key
(perl (default-perl))
(search-paths '()) (search-paths '())
(tests? #t) (tests? #t)
(parallel-build? #t) (parallel-build? #t)
@ -62,20 +86,19 @@
(guix build utils)))) (guix build utils))))
"Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE "Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE
provides a `Makefile.PL' file as its build system." provides a `Makefile.PL' file as its build system."
(define perl-search-paths
(append (package-native-search-paths perl)
(standard-search-paths)))
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(perl-build #:name ,name (perl-build #:name ,name
#:source ,(if (derivation? source) #:source ,(match (assoc-ref inputs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append perl-search-paths search-paths)
search-paths))
#:make-maker-flags ,make-maker-flags #:make-maker-flags ,make-maker-flags
#:phases ,phases #:phases ,phases
#:system ,system #:system ,system
@ -95,27 +118,17 @@ provides a `Makefile.PL' file as its build system."
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system)))))
(let ((perl (package-derivation store perl system))) (build-expression->derivation store name builder
(build-expression->derivation store name builder #:system system
#:system system #:inputs inputs
#:inputs #:modules imported-modules
`(,@(if source #:outputs outputs
`(("source" ,source)) #:guile-for-build guile-for-build))
'())
("perl" ,perl)
,@inputs
;; Keep the standard inputs of
;; `gnu-build-system'.
,@(standard-inputs system))
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build)))
(define perl-build-system (define perl-build-system
(build-system (name 'perl) (build-system
(description "The standard Perl build system") (name 'perl)
(build perl-build))) (description "The standard Perl build system")
(lower lower)))
;;; perl.scm ends here ;;; perl.scm ends here

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

@ -92,9 +92,33 @@ prepended to the name."
(define package-with-python2 (define package-with-python2
(cut package-with-explicit-python <> (default-python2) "python-" "python2-")) (cut package-with-explicit-python <> (default-python2) "python-" "python2-"))
(define* (python-build store name source inputs (define* (lower name
#:key source inputs native-inputs outputs target
(python (default-python))
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
'(#:source #:target #:python #:inputs #:native-inputs))
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs
;; Keep the standard inputs of 'gnu-build-system'.
,@(standard-packages)))
(build-inputs `(("python" ,python)
,@native-inputs))
(outputs outputs)
(build python-build)
(arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (python-build store name inputs
#:key #:key
(python (default-python))
(tests? #t) (tests? #t)
(test-target "test") (test-target "test")
(configure-flags ''()) (configure-flags ''())
@ -111,18 +135,17 @@ prepended to the name."
(guix build utils)))) (guix build utils))))
"Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE "Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE
provides a 'setup.py' file as its build system." provides a 'setup.py' file as its build system."
(define python-search-paths
(append (package-native-search-paths python)
(standard-search-paths)))
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(python-build #:name ,name (python-build #:name ,name
#:source ,(if (derivation? source) #:source ,(match (assoc-ref inputs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:configure-flags ,configure-flags #:configure-flags ,configure-flags
#:system ,system #:system ,system
#:test-target ,test-target #:test-target ,test-target
@ -130,8 +153,7 @@ provides a 'setup.py' file as its build system."
#:phases ,phases #:phases ,phases
#:outputs %outputs #:outputs %outputs
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append python-search-paths search-paths)
search-paths))
#:inputs %build-inputs))) #:inputs %build-inputs)))
(define guile-for-build (define guile-for-build
@ -143,27 +165,17 @@ provides a 'setup.py' file as its build system."
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system)))))
(let ((python (package-derivation store python system))) (build-expression->derivation store name builder
(build-expression->derivation store name builder #:inputs inputs
#:inputs #:system system
`(,@(if source #:modules imported-modules
`(("source" ,source)) #:outputs outputs
'()) #:guile-for-build guile-for-build))
("python" ,python)
,@inputs
;; Keep the standard inputs of
;; 'gnu-build-system'.
,@(standard-inputs system))
#:system system
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build)))
(define python-build-system (define python-build-system
(build-system (name 'python) (build-system
(description "The standard Python build system") (name 'python)
(build python-build))) (description "The standard Python build system")
(lower lower)))
;;; python.scm ends here ;;; python.scm ends here

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

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -23,9 +24,7 @@
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix build-system) #:use-module (guix build-system)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (gnu packages version-control)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:export (ruby-build #:export (ruby-build
ruby-build-system)) ruby-build-system))
@ -35,9 +34,33 @@
(let ((ruby (resolve-interface '(gnu packages ruby)))) (let ((ruby (resolve-interface '(gnu packages ruby))))
(module-ref ruby 'ruby))) (module-ref ruby 'ruby)))
(define* (ruby-build store name source inputs (define* (lower name
#:key source inputs native-inputs outputs target
(ruby (default-ruby))
#:allow-other-keys
#:rest arguments)
"Return a bag for NAME."
(define private-keywords
'(#:source #:target #:ruby #:inputs #:native-inputs))
(and (not target) ;XXX: no cross-compilation
(bag
(name name)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs
;; Keep the standard inputs of 'gnu-build-system'.
,@(standard-packages)))
(build-inputs `(("ruby" ,ruby)
,@native-inputs))
(outputs outputs)
(build ruby-build)
(arguments (strip-keyword-arguments private-keywords arguments)))))
(define* (ruby-build store name inputs
#:key #:key
(ruby (default-ruby))
(test-target "test") (test-target "test")
(tests? #t) (tests? #t)
(phases '(@ (guix build ruby-build-system) (phases '(@ (guix build ruby-build-system)
@ -52,25 +75,24 @@
(modules '((guix build ruby-build-system) (modules '((guix build ruby-build-system)
(guix build utils)))) (guix build utils))))
"Build SOURCE using RUBY and INPUTS." "Build SOURCE using RUBY and INPUTS."
(define ruby-search-paths
(append (package-native-search-paths ruby)
(standard-search-paths)))
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
(ruby-build #:name ,name (ruby-build #:name ,name
#:source ,(if (derivation? source) #:source ,(match (assoc-ref inputs "source")
(derivation->output-path source) (((? derivation? source))
source) (derivation->output-path source))
((source)
source)
(source
source))
#:system ,system #:system ,system
#:test-target ,test-target #:test-target ,test-target
#:tests? ,tests? #:tests? ,tests?
#:phases ,phases #:phases ,phases
#:outputs %outputs #:outputs %outputs
#:search-paths ',(map search-path-specification->sexp #:search-paths ',(map search-path-specification->sexp
(append ruby-search-paths search-paths)
search-paths))
#:inputs %build-inputs))) #:inputs %build-inputs)))
(define guile-for-build (define guile-for-build
@ -82,25 +104,15 @@
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system)))))
(let ((ruby (package-derivation store ruby system)) (build-expression->derivation store name builder
(git (package-derivation store git system))) #:inputs inputs
(build-expression->derivation store name builder #:system system
#:inputs #:modules imported-modules
`(,@(if source #:outputs outputs
`(("source" ,source)) #:guile-for-build guile-for-build))
'())
("ruby" ,ruby)
,@inputs
;; Keep the standard inputs of
;; 'gnu-build-system'.
,@(standard-inputs system))
#:system system
#:modules imported-modules
#:outputs outputs
#:guile-for-build guile-for-build)))
(define ruby-build-system (define ruby-build-system
(build-system (build-system
(name 'ruby) (name 'ruby)
(description "The standard Ruby build system") (description "The standard Ruby build system")
(build ruby-build))) (lower lower)))

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

@ -34,42 +34,55 @@
(guile (module-ref distro 'guile-final))) (guile (module-ref distro 'guile-final)))
(package-derivation store guile system))))) (package-derivation store guile system)))))
(define* (trivial-build store name source inputs (define* (lower name
#:key source inputs native-inputs outputs target
guile builder modules)
"Return a bag for NAME."
(bag
(name name)
(host-inputs `(,@(if source
`(("source" ,source))
'())
,@inputs))
(build-inputs native-inputs)
(outputs outputs)
(build (if target trivial-cross-build trivial-build))
(arguments `(#:guile ,guile
#:builder ,builder
#:modules ,modules))))
(define* (trivial-build store name inputs
#:key #:key
outputs guile system builder (modules '()) outputs guile system builder (modules '())
search-paths) search-paths)
"Run build expression BUILDER, an expression, for SYSTEM. SOURCE is "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is
ignored." ignored."
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:inputs (if source #:inputs inputs
`(("source" ,source) ,@inputs)
inputs)
#:system system #:system system
#:outputs outputs #:outputs outputs
#:modules modules #:modules modules
#:guile-for-build #:guile-for-build
(guile-for-build store guile system))) (guile-for-build store guile system)))
(define* (trivial-cross-build store name target source inputs native-inputs (define* (trivial-cross-build store name
#:key #:key
target native-drvs target-drvs
outputs guile system builder (modules '()) outputs guile system builder (modules '())
search-paths native-search-paths) search-paths native-search-paths)
"Like `trivial-build', but in a cross-compilation context." "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is
ignored."
(build-expression->derivation store name builder (build-expression->derivation store name builder
#:inputs (append native-drvs target-drvs)
#:system system #:system system
#:inputs
(let ((inputs (append native-inputs inputs)))
(if source
`(("source" ,source) ,@inputs)
inputs))
#:outputs outputs #:outputs outputs
#:modules modules #:modules modules
#:guile-for-build #:guile-for-build
(guile-for-build store guile system))) (guile-for-build store guile system)))
(define trivial-build-system (define trivial-build-system
(build-system (name 'trivial) (build-system
(description (name 'trivial)
"Trivial build system, to run arbitrary Scheme build expressions") (description
(build trivial-build) "Trivial build system, to run arbitrary Scheme build expressions")
(cross-build trivial-cross-build))) (lower lower)))

4
guix/git-download.scm
View File

@ -21,7 +21,7 @@
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix packages) #:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-inputs) #:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (git-reference #:export (git-reference
git-reference? git-reference?
@ -73,7 +73,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if
;; When doing 'git clone --recursive', we need sed, grep, etc. to be ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
;; available so that 'git submodule' works. ;; available so that 'git submodule' works.
(if (git-reference-recursive? ref) (if (git-reference-recursive? ref)
(standard-inputs (%current-system)) (standard-packages)
'())) '()))
(define build (define build

191
guix/packages.scm
View File

@ -92,7 +92,13 @@
package-input-error? package-input-error?
package-error-invalid-input package-error-invalid-input
&package-cross-build-system-error &package-cross-build-system-error
package-cross-build-system-error?)) package-cross-build-system-error?
package->bag
bag-transitive-inputs
bag-transitive-host-inputs
bag-transitive-build-inputs
bag-transitive-target-inputs))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -519,6 +525,24 @@ for the host system (\"native inputs\"), and not target inputs."
recursively." recursively."
(transitive-inputs (package-propagated-inputs package))) (transitive-inputs (package-propagated-inputs package)))
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."
(transitive-inputs (append (bag-build-inputs bag)
(bag-host-inputs bag)
(bag-target-inputs bag))))
(define (bag-transitive-build-inputs bag)
"Same as 'package-transitive-native-inputs', but applied to a bag."
(transitive-inputs (bag-build-inputs bag)))
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
(transitive-inputs (bag-host-inputs bag)))
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
(transitive-inputs (bag-target-inputs bag)))
;;; ;;;
;;; Package derivations. ;;; Package derivations.
@ -591,6 +615,38 @@ information in exceptions."
(package package) (package package)
(input x))))))) (input x)))))))
(define* (package->bag package #:optional
(system (%current-system))
(target (%current-target-system)))
"Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it."
;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
;; values can refer to it.
(parameterize ((%current-system system)
(%current-target-system target))
(match package
(($ <package> name version source build-system
args inputs propagated-inputs native-inputs self-native-input?
outputs)
(or (make-bag build-system (package-full-name package)
#:target target
#:source source
#:inputs (append (inputs)
(propagated-inputs))
#:outputs outputs
#:native-inputs `(,@(if (and target self-native-input?)
`(("self" ,package))
'())
,@(native-inputs))
#:arguments (args))
(raise (if target
(condition
(&package-cross-build-system-error
(package package)))
(condition
(&package-error
(package package))))))))))
(define* (package-derivation store package (define* (package-derivation store package
#:optional (system (%current-system))) #:optional (system (%current-system)))
"Return the <derivation> object of PACKAGE for SYSTEM." "Return the <derivation> object of PACKAGE for SYSTEM."
@ -599,92 +655,69 @@ information in exceptions."
;; because some derivations, such as the implicit inputs of the GNU build ;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row. ;; system, will be queried many, many times in a row.
(cached package system (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))))
;; Bind %CURRENT-SYSTEM so that thunked field values can refer (apply (bag-build bag)
;; to it. store (bag-name bag)
(parameterize ((%current-system system) input-drvs
(%current-target-system #f)) #:search-paths paths
(match package #:outputs (bag-outputs bag) #:system system
(($ <package> name version source (= build-system-builder builder) (bag-arguments bag)))))
args inputs propagated-inputs native-inputs self-native-input?
outputs)
(let* ((inputs (package-transitive-inputs package))
(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 builder
store (package-full-name package)
(and source
(package-source-derivation store source system))
input-drvs
#:search-paths paths
#:outputs outputs #:system system
(args))))))))
(define* (package-cross-derivation store package target (define* (package-cross-derivation store package target
#:optional (system (%current-system))) #:optional (system (%current-system)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)." system identifying string)."
(cached package (cons system target) (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))))
;; Bind %CURRENT-SYSTEM so that thunked field values can refer (apply (bag-build bag)
;; to it. store (bag-name bag)
(parameterize ((%current-system system) #:native-drvs build-drvs
(%current-target-system target)) #:target-drvs (append host-drvs target-drvs)
(match package #:search-paths paths
(($ <package> name version source #:native-search-paths npaths
(= build-system-cross-builder builder) #:outputs (bag-outputs bag)
args inputs propagated-inputs native-inputs self-native-input? #:system system #:target target
outputs) (bag-arguments bag)))))
(unless builder
(raise (condition
(&package-cross-build-system-error
(package package)))))
(let* ((inputs (package-transitive-target-inputs package))
(input-drvs (map (cut expand-input
store package <>
system target)
inputs))
(host (append (if self-native-input?
`(("self" ,package))
'())
(package-transitive-native-inputs package)))
(host-drvs (map (cut expand-input
store package <> system)
host))
(all (append host inputs))
(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 builder
store (package-full-name package) target
(and source
(package-source-derivation store source system))
input-drvs host-drvs
#:search-paths paths
#:native-search-paths npaths
#:outputs outputs #:system system
(args))))))))
(define* (package-output store package (define* (package-output store package
#:optional (output "out") (system (%current-system))) #:optional (output "out") (system (%current-system)))

9
tests/builders.scm
View File

@ -92,8 +92,7 @@
(valid-path? %store out)))) (valid-path? %store out))))
(test-assert "gnu-build-system" (test-assert "gnu-build-system"
(and (build-system? gnu-build-system) (build-system? gnu-build-system))
(eq? gnu-build (build-system-builder gnu-build-system))))
(unless network-reachable? (test-skip 1)) (unless network-reachable? (test-skip 1))
(test-assert "gnu-build" (test-assert "gnu-build"
@ -102,9 +101,9 @@
"0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6"))
(tarball (url-fetch %store url 'sha256 hash (tarball (url-fetch %store url 'sha256 hash
#:guile %bootstrap-guile)) #:guile %bootstrap-guile))
(build (gnu-build %store "hello-2.8" tarball (build (gnu-build %store "hello-2.8"
%bootstrap-inputs `(("source" ,tarball)
#:implicit-inputs? #f ,@%bootstrap-inputs)
#:guile %bootstrap-guile #:guile %bootstrap-guile
#:search-paths %bootstrap-search-paths)) #:search-paths %bootstrap-search-paths))
(out (derivation->output-path build))) (out (derivation->output-path build)))

15
tests/packages.scm
View File

@ -279,11 +279,16 @@
(test-assert "search paths" (test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths")) (let* ((p (make-prompt-tag "return-search-paths"))
(s (build-system (s (build-system
(name "raw") (name 'raw)
(description "Raw build system with direct store access") (description "Raw build system with direct store access")
(build (lambda* (store name source inputs (lower (lambda* (name #:key source inputs #:allow-other-keys)
#:key outputs system search-paths) (bag
search-paths)))) (name name)
(build-inputs inputs)
(build
(lambda* (store name inputs
#:key outputs system search-paths)
search-paths)))))))
(x (list (search-path-specification (x (list (search-path-specification
(variable "GUILE_LOAD_PATH") (variable "GUILE_LOAD_PATH")
(directories '("share/guile/site/2.0"))) (directories '("share/guile/site/2.0")))
@ -326,7 +331,7 @@
(test-assert "package-cross-derivation, no cross builder" (test-assert "package-cross-derivation, no cross builder"
(let* ((b (build-system (inherit trivial-build-system) (let* ((b (build-system (inherit trivial-build-system)
(cross-build #f))) (lower (const #f))))
(p (package (inherit (dummy-package "p")) (p (package (inherit (dummy-package "p"))
(build-system b)))) (build-system b))))
(guard (c ((package-cross-build-system-error? c) (guard (c ((package-cross-build-system-error? c)