diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | gnu/packages/cross-base.scm | 5 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 225 | ||||
| -rw-r--r-- | guix/build/gnu-cross-build.scm | 138 |
4 files changed, 348 insertions, 21 deletions
diff --git a/Makefile.am b/Makefile.am index e8a37bf980..8592c5bf99 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 \ diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index 06e66541de..22878a20b0 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.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) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index b64bce7dae..4d06a8b583 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -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))) diff --git a/guix/build/gnu-cross-build.scm b/guix/build/gnu-cross-build.scm new file mode 100644 index 0000000000..dab60684ac --- /dev/null +++ b/guix/build/gnu-cross-build.scm @@ -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 |