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.

2 files changed, 343 insertions, 20 deletions

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