build-system/gnu: Implement cross build.
* guix/build-system/gnu.scm (inputs-search-paths): New procedure. (standard-search-paths): Use it. (expand-inputs): New procedure. (standard-inputs): Use it. (standard-cross-packages, standard-cross-inputs, standard-cross-search-paths, gnu-cross-build): New procedures. (gnu-build-system): Set `cross-build' field to `gnu-cross-build'. * gnu/packages/cross-base.scm: Export `cross-gcc', `cross-binutils', and `cross-libc'. * guix/build/gnu-cross-build.scm: New file. * Makefile.am (MODULES): Add it.master
Ludovic Courtès
parent
9c1edabd8b
commit
264218a47e
|
|
@ -57,6 +57,7 @@ MODULES = \
|
|||
guix/build/download.scm \
|
||||
guix/build/cmake-build-system.scm \
|
||||
guix/build/gnu-build-system.scm \
|
||||
guix/build/gnu-cross-build.scm \
|
||||
guix/build/perl-build-system.scm \
|
||||
guix/build/python-build-system.scm \
|
||||
guix/build/utils.scm \
|
||||
|
|
|
|||
|
|
@ -29,7 +29,10 @@
|
|||
#:use-module (guix build-system trivial)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (ice-9 match))
|
||||
#:use-module (ice-9 match)
|
||||
#:export (cross-binutils
|
||||
cross-libc
|
||||
cross-gcc))
|
||||
|
||||
(define (cross p target)
|
||||
(package (inherit p)
|
||||
|
|
|
|||
|
|
@ -144,35 +144,48 @@ standard packages used as implicit inputs of the GNU build system."
|
|||
(let ((distro (resolve-module '(gnu packages base))))
|
||||
(module-ref distro '%final-inputs)))
|
||||
|
||||
(define (standard-search-paths)
|
||||
"Return the list of <search-path-specification> for the standard (implicit)
|
||||
inputs."
|
||||
(define* (inputs-search-paths inputs
|
||||
#:optional (package->search-paths
|
||||
package-native-search-paths))
|
||||
"Return the <search-path-specification> objects for INPUTS, using
|
||||
PACKAGE->SEARCH-PATHS to extract the search path specifications of a package."
|
||||
(append-map (match-lambda
|
||||
((_ (? package? p) _ ...)
|
||||
(package-native-search-paths p))
|
||||
(package->search-paths p))
|
||||
(_
|
||||
'()))
|
||||
(standard-packages)))
|
||||
inputs))
|
||||
|
||||
(define (standard-search-paths)
|
||||
"Return the list of <search-path-specification> for the standard (implicit)
|
||||
inputs when doing a native build."
|
||||
(inputs-search-paths (standard-packages)))
|
||||
|
||||
(define (expand-inputs inputs system)
|
||||
"Expand INPUTS, which contains <package> objects, so that it contains only
|
||||
derivations for SYSTEM. Include propagated inputs in the result."
|
||||
(define input-package->derivation
|
||||
(match-lambda
|
||||
((name pkg sub-drv ...)
|
||||
(cons* name (package-derivation (%store) pkg system) sub-drv))
|
||||
((name (? derivation-path? path) sub-drv ...)
|
||||
(cons* name path sub-drv))
|
||||
(z
|
||||
(error "invalid standard input" z))))
|
||||
|
||||
(map input-package->derivation
|
||||
(append inputs
|
||||
(append-map (match-lambda
|
||||
((name package _ ...)
|
||||
(package-transitive-propagated-inputs package)))
|
||||
inputs))))
|
||||
|
||||
(define standard-inputs
|
||||
(memoize
|
||||
(lambda (system)
|
||||
"Return the list of implicit standard inputs used with the GNU Build
|
||||
System: GCC, GNU Make, Bash, Coreutils, etc."
|
||||
(map (match-lambda
|
||||
((name pkg sub-drv ...)
|
||||
(cons* name (package-derivation (%store) pkg system) sub-drv))
|
||||
((name (? derivation-path? path) sub-drv ...)
|
||||
(cons* name path sub-drv))
|
||||
(z
|
||||
(error "invalid standard input" z)))
|
||||
|
||||
(let ((inputs (standard-packages)))
|
||||
(append inputs
|
||||
(append-map (match-lambda
|
||||
((name package _ ...)
|
||||
(package-transitive-propagated-inputs package)))
|
||||
inputs)))))))
|
||||
(expand-inputs (standard-packages) system))))
|
||||
|
||||
(define* (gnu-build store name source inputs
|
||||
#:key (guile #f)
|
||||
|
|
@ -269,8 +282,180 @@ which could lead to gratuitous input divergence."
|
|||
#:modules imported-modules
|
||||
#:guile-for-build guile-for-build))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Cross-compilation.
|
||||
;;;
|
||||
|
||||
(define standard-cross-packages
|
||||
(memoize
|
||||
(lambda (target kind)
|
||||
"Return the list of name/package tuples to cross-build for TARGET. KIND
|
||||
is one of `host' or `target'."
|
||||
(let* ((cross (resolve-interface '(gnu packages cross-base)))
|
||||
(gcc (module-ref cross 'cross-gcc))
|
||||
(binutils (module-ref cross 'cross-binutils))
|
||||
(libc (module-ref cross 'cross-libc)))
|
||||
(case kind
|
||||
((host)
|
||||
`(("cross-gcc" ,(gcc target
|
||||
(binutils target)
|
||||
(libc target)))
|
||||
("cross-binutils" ,(binutils target))
|
||||
,@(standard-packages)))
|
||||
((target)
|
||||
`(("cross-libc" ,(libc target)))))))))
|
||||
|
||||
(define standard-cross-inputs
|
||||
(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
|
||||
(guile #f)
|
||||
(outputs '("out"))
|
||||
(search-paths '())
|
||||
(native-search-paths '())
|
||||
|
||||
(configure-flags ''())
|
||||
(make-flags ''())
|
||||
(patches ''()) (patch-flags ''("--batch" "-p1"))
|
||||
(out-of-source? #f)
|
||||
(tests? #t)
|
||||
(test-target "check")
|
||||
(parallel-build? #t) (parallel-tests? #t)
|
||||
(patch-shebangs? #t)
|
||||
(strip-binaries? #t)
|
||||
(strip-flags ''("--strip-debug"))
|
||||
(strip-directories ''("lib" "lib64" "libexec"
|
||||
"bin" "sbin"))
|
||||
(phases '%standard-cross-phases)
|
||||
(system (%current-system))
|
||||
(implicit-inputs? #t) ; useful when bootstrapping
|
||||
(imported-modules '((guix build gnu-build-system)
|
||||
(guix build gnu-cross-build)
|
||||
(guix build utils)))
|
||||
(modules '((guix build gnu-build-system)
|
||||
(guix build gnu-cross-build)
|
||||
(guix build utils))))
|
||||
"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
|
||||
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 builder
|
||||
`(begin
|
||||
(use-modules ,@modules)
|
||||
|
||||
(let ()
|
||||
(define %build-host-inputs
|
||||
',(map (match-lambda
|
||||
((name (? derivation-path? drv-path) sub ...)
|
||||
`(,name . ,(apply derivation-path->output-path
|
||||
drv-path sub)))
|
||||
(x x))
|
||||
(append (or implicit-host-inputs '()) native-inputs)))
|
||||
|
||||
(define %build-target-inputs
|
||||
',(map (match-lambda
|
||||
((name (? derivation-path? drv-path) sub ...)
|
||||
`(,name . ,(apply derivation-path->output-path
|
||||
drv-path sub)))
|
||||
(x x))
|
||||
(append (or implicit-target-inputs) inputs)))
|
||||
|
||||
(gnu-build #:source ,(if (and source (derivation-path? source))
|
||||
(derivation-path->output-path source)
|
||||
source)
|
||||
#:system ,system
|
||||
#:target ,target
|
||||
#:outputs %outputs
|
||||
#:inputs %build-target-inputs
|
||||
#:native-inputs %build-host-inputs
|
||||
#:search-paths ',(map search-path-specification->sexp
|
||||
(append implicit-target-search-paths
|
||||
search-paths))
|
||||
#:native-search-paths ',(map
|
||||
search-path-specification->sexp
|
||||
(append implicit-host-search-paths
|
||||
native-search-paths))
|
||||
#:patches ,patches
|
||||
#:patch-flags ,patch-flags
|
||||
#:phases ,phases
|
||||
#:configure-flags ,configure-flags
|
||||
#:make-flags ,make-flags
|
||||
#:out-of-source? ,out-of-source?
|
||||
#:tests? ,tests?
|
||||
#:test-target ,test-target
|
||||
#:parallel-build? ,parallel-build?
|
||||
#:parallel-tests? ,parallel-tests?
|
||||
#:patch-shebangs? ,patch-shebangs?
|
||||
#:strip-binaries? ,strip-binaries?
|
||||
#:strip-flags ,strip-flags
|
||||
#:strip-directories ,strip-directories))))
|
||||
|
||||
(define guile-for-build
|
||||
(match guile
|
||||
((? package?)
|
||||
(package-derivation store guile system))
|
||||
((and (? string?) (? derivation-path?))
|
||||
guile)
|
||||
(#f ; the default
|
||||
(let* ((distro (resolve-interface '(gnu packages base)))
|
||||
(guile (module-ref distro 'guile-final)))
|
||||
(package-derivation store guile system)))))
|
||||
|
||||
(build-expression->derivation store name system
|
||||
builder
|
||||
`(,@(if source
|
||||
`(("source" ,source))
|
||||
'())
|
||||
,@inputs
|
||||
,@(if implicit-inputs?
|
||||
implicit-target-inputs
|
||||
'())
|
||||
,@native-inputs
|
||||
,@(if implicit-inputs?
|
||||
implicit-host-inputs
|
||||
'()))
|
||||
#:outputs outputs
|
||||
#:modules imported-modules
|
||||
#:guile-for-build guile-for-build))
|
||||
|
||||
(define gnu-build-system
|
||||
(build-system (name 'gnu)
|
||||
(description
|
||||
"The GNU Build System—i.e., ./configure && make && make install")
|
||||
(build gnu-build))) ; TODO: add `gnu-cross-build'
|
||||
(build gnu-build)
|
||||
(cross-build gnu-cross-build)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,138 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix build gnu-cross-build)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module ((guix build gnu-build-system)
|
||||
#:renamer (symbol-prefix-proc 'build:))
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (%standard-cross-phases
|
||||
gnu-cross-build))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Extension of `gnu-build-system.scm' to support cross-compilation.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define* (set-paths #:key inputs native-inputs
|
||||
(search-paths '()) (native-search-paths '())
|
||||
#:allow-other-keys)
|
||||
(define input-directories
|
||||
(match inputs
|
||||
(((_ . dir) ...)
|
||||
dir)))
|
||||
|
||||
(define native-input-directories
|
||||
(match native-inputs
|
||||
(((_ . dir) ...)
|
||||
dir)))
|
||||
|
||||
;; $PATH must refer only to native (host) inputs since target inputs are not
|
||||
;; executable.
|
||||
(set-path-environment-variable "PATH" '("bin" "sbin")
|
||||
native-input-directories)
|
||||
|
||||
;; Search paths for target inputs.
|
||||
(for-each (match-lambda
|
||||
((env-var (directories ...) separator)
|
||||
(set-path-environment-variable env-var directories
|
||||
input-directories
|
||||
#:separator separator)))
|
||||
search-paths)
|
||||
|
||||
;; Search paths for native inputs.
|
||||
(for-each (match-lambda
|
||||
((env-var (directories ...) separator)
|
||||
(set-path-environment-variable env-var directories
|
||||
native-input-directories
|
||||
#:separator separator)))
|
||||
native-search-paths)
|
||||
|
||||
;; Dump the environment variables as a shell script, for handy debugging.
|
||||
(system "export > environment-variables"))
|
||||
|
||||
(define* (configure #:key
|
||||
inputs outputs (configure-flags '()) out-of-source?
|
||||
target native-inputs
|
||||
#:allow-other-keys)
|
||||
(format #t "configuring for cross-compilation to `~a'~%" target)
|
||||
(apply (assoc-ref build:%standard-phases 'configure)
|
||||
#:configure-flags (cons (string-append "--host=" target)
|
||||
configure-flags)
|
||||
|
||||
;; XXX: The underlying `configure' phase looks for Bash among
|
||||
;; #:inputs, so fool it this way.
|
||||
#:inputs native-inputs
|
||||
|
||||
#:outputs outputs
|
||||
#:out-of-source? out-of-source?
|
||||
'()))
|
||||
|
||||
(define* (strip #:key target outputs (strip-binaries? #t)
|
||||
(strip-flags '("--strip-debug"))
|
||||
(strip-directories '("lib" "lib64" "libexec"
|
||||
"bin" "sbin"))
|
||||
#:allow-other-keys)
|
||||
;; TODO: The only difference with `strip' in gnu-build-system.scm is the
|
||||
;; name of the strip command; factorize it.
|
||||
|
||||
(define (strip-dir dir)
|
||||
(format #t "stripping binaries in ~s with flags ~s~%"
|
||||
dir strip-flags)
|
||||
(file-system-fold (const #t)
|
||||
(lambda (path stat result) ; leaf
|
||||
(zero? (apply system*
|
||||
(string-append target "-strip")
|
||||
(append strip-flags (list path)))))
|
||||
(const #t) ; down
|
||||
(const #t) ; up
|
||||
(const #t) ; skip
|
||||
(lambda (path stat errno result)
|
||||
(format (current-error-port)
|
||||
"strip: failed to access `~a': ~a~%"
|
||||
path (strerror errno))
|
||||
#f)
|
||||
#t
|
||||
dir))
|
||||
|
||||
(or (not strip-binaries?)
|
||||
(every strip-dir
|
||||
(append-map (match-lambda
|
||||
((_ . dir)
|
||||
(filter-map (lambda (d)
|
||||
(let ((sub (string-append dir "/" d)))
|
||||
(and (directory-exists? sub) sub)))
|
||||
strip-directories)))
|
||||
outputs))))
|
||||
|
||||
(define %standard-cross-phases
|
||||
;; The standard phases when cross-building.
|
||||
(let ((replacements `((set-paths ,set-paths)
|
||||
(configure ,configure)
|
||||
(strip ,strip))))
|
||||
(fold (lambda (replacement phases)
|
||||
(match replacement
|
||||
((name proc)
|
||||
(alist-replace name proc phases))))
|
||||
(alist-delete 'check build:%standard-phases)
|
||||
replacements)))
|
||||
|
||||
;;; gnu-cross-build.scm ends here
|
||||
Reference in New Issue