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

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.
This commit is contained in:
Ludovic Courtès 2013-05-24 22:44:15 +02:00
parent 9c1edabd8b
commit 264218a47e
4 changed files with 348 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -57,6 +57,7 @@ MODULES = \
guix/build/download.scm \ guix/build/download.scm \
guix/build/cmake-build-system.scm \ guix/build/cmake-build-system.scm \
guix/build/gnu-build-system.scm \ guix/build/gnu-build-system.scm \
guix/build/gnu-cross-build.scm \
guix/build/perl-build-system.scm \ guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \ guix/build/python-build-system.scm \
guix/build/utils.scm \ guix/build/utils.scm \

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

@ -29,7 +29,10 @@
#:use-module (guix build-system trivial) #:use-module (guix build-system trivial)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #: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) (define (cross p target)
(package (inherit p) (package (inherit p)

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

@ -144,35 +144,48 @@ standard packages used as implicit inputs of the GNU build system."
(let ((distro (resolve-module '(gnu packages base)))) (let ((distro (resolve-module '(gnu packages base))))
(module-ref distro '%final-inputs))) (module-ref distro '%final-inputs)))
(define (standard-search-paths) (define* (inputs-search-paths inputs
"Return the list of <search-path-specification> for the standard (implicit) #:optional (package->search-paths
inputs." 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 (append-map (match-lambda
((_ (? package? p) _ ...) ((_ (? 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 (define standard-inputs
(memoize (memoize
(lambda (system) (lambda (system)
"Return the list of implicit standard inputs used with the GNU Build "Return the list of implicit standard inputs used with the GNU Build
System: GCC, GNU Make, Bash, Coreutils, etc." System: GCC, GNU Make, Bash, Coreutils, etc."
(map (match-lambda (expand-inputs (standard-packages) system))))
((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)))))))
(define* (gnu-build store name source inputs (define* (gnu-build store name source inputs
#:key (guile #f) #:key (guile #f)
@ -269,8 +282,180 @@ which could lead to gratuitous input divergence."
#:modules imported-modules #:modules imported-modules
#:guile-for-build guile-for-build)) #: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 (define gnu-build-system
(build-system (name 'gnu) (build-system (name 'gnu)
(description (description
"The GNU Build System—i.e., ./configure && make && make install") "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)))

138
guix/build/gnu-cross-build.scm Normal file
View File

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