guix/guix
3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
Code Issues Releases Wiki Activity

build-system/gnu: Implement cross build.

Browse source 
* 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/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 \

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

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

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

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