packages: Implement `package-cross-derivation'.

* guix/packages.scm (package-transitive-target-inputs,
  package-transitive-native-inputs): New procedures.
  (package-derivation): Parametrize `%current-target-system'.
  (package-cross-derivation): Implement.
* guix/utils.scm (%current-target-system): New variable.
* tests/packages.scm ("package-cross-derivation"): New test.
* doc/guix.texi (Defining Packages): Document
  `package-cross-derivation'.

4 files changed, 98 insertions, 5 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index c3aab812e2..1cf5849dd3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -919,6 +919,23 @@ must be a connection to the daemon, which operates on the store
 (@pxref{The Store}).
 @end deffn
 
+@noindent
+@cindex cross-compilation
+Similarly, it is possible to compute a derivation that cross-builds a
+package for some other system:
+
+@deffn {Scheme Procedure} package-cross-derivation @var{store} @
+            @var{package} @var{target} [@var{system}]
+Return the derivation path and corresponding @code{<derivation>} object
+of @var{package} cross-built from @var{system} to @var{target}.
+
+@var{target} must be a valid GNU triplet denoting the target hardware
+and operating system, such as @code{"mips64el-linux-gnu"}
+(@pxref{Configuration Names, GNU configuration triplets,, configure, GNU
+Configure and Build System}).
+@end deffn
+
+
 @node The Store
 @section The Store
 
diff --git a/guix/packages.scm b/guix/packages.scm
index 242b912d5d..6321a58374 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -69,6 +69,8 @@
             package-field-location
 
             package-transitive-inputs
+            package-transitive-target-inputs
+            package-transitive-native-inputs
             package-transitive-propagated-inputs
             package-source-derivation
             package-derivation
@@ -268,6 +270,19 @@ with their propagated inputs, recursively."
                              (package-inputs package)
                              (package-propagated-inputs package))))
 
+(define (package-transitive-target-inputs package)
+  "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
+along with their propagated inputs, recursively.  This only includes inputs
+for the target system, and not native inputs."
+  (transitive-inputs (append (package-inputs package)
+                             (package-propagated-inputs package))))
+
+(define (package-transitive-native-inputs package)
+  "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
+along with their propagated inputs, recursively.  This only includes inputs
+for the host system (\"native inputs\"), and not target inputs."
+  (transitive-inputs (package-native-inputs package)))
+
 (define (package-transitive-propagated-inputs package)
   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 recursively."
@@ -354,7 +369,8 @@ PACKAGE for SYSTEM."
 
           ;; Bind %CURRENT-SYSTEM so that thunked field values can refer
           ;; to it.
-          (parameterize ((%current-system system))
+          (parameterize ((%current-system system)
+                         (%current-target-system #f))
             (match package
               (($ <package> name version source (= build-system-builder builder)
                   args inputs propagated-inputs native-inputs self-native-input?
@@ -380,10 +396,57 @@ PACKAGE for SYSTEM."
                         #:outputs outputs #:system system
                         (args))))))))
 
-(define* (package-cross-derivation store package cross-system
+(define* (package-cross-derivation store package target
                                    #:optional (system (%current-system)))
-  ;; TODO
-  #f)
+  "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
+system identifying string)."
+  (cached package (cons system target)
+
+          ;; Bind %CURRENT-SYSTEM so that thunked field values can refer
+          ;; to it.
+          (parameterize ((%current-system system)
+                         (%current-target-system target))
+            (match package
+              (($ <package> name version source
+                  (= build-system-cross-builder builder)
+                  args inputs propagated-inputs native-inputs self-native-input?
+                  outputs)
+               (let* ((inputs     (package-transitive-target-inputs package))
+                      (input-drvs (map (cut expand-input
+                                            store package <>
+                                            system target)
+                                       inputs))
+                      (host       (append (if self-native-input?
+                                              `(("self" ,package))
+                                              '())
+                                          (package-transitive-native-inputs package)))
+                      (host-drvs  (map (cut expand-input
+                                            store package <> system)
+                                       host))
+                      (all        (append host inputs))
+                      (paths      (delete-duplicates
+                                   (append-map (match-lambda
+                                                ((_ (? package? p) _ ...)
+                                                 (package-search-paths p))
+                                                (_ '()))
+                                               all)))
+                      (npaths     (delete-duplicates
+                                   (append-map (match-lambda
+                                                ((_ (? package? p) _ ...)
+                                                 (package-native-search-paths
+                                                  p))
+                                                (_ '()))
+                                               all))))
+
+                 (apply builder
+                        store (package-full-name package) target
+                        (and source
+                             (package-source-derivation store source system))
+                        input-drvs host-drvs
+                        #:search-paths paths
+                        #:native-search-paths npaths
+                        #:outputs outputs #:system system
+                        (args))))))))
 
 (define* (package-output store package output
                          #:optional (system (%current-system)))
diff --git a/guix/utils.scm b/guix/utils.scm
index 25a392e6a8..2478fb6939 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -57,6 +57,7 @@
 
             gnu-triplet->nix-system
             %current-system
+            %current-target-system
             version-compare
             version>?
             package-name->name+version
@@ -310,6 +311,11 @@ returned by `config.guess'."
   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
   (make-parameter %system))
 
+(define %current-target-system
+  ;; Either #f or a GNU triplet representing the target system we are
+  ;; cross-building to.
+  (make-parameter #f))
+
 (define version-compare
   (let ((strverscmp
          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
diff --git a/tests/packages.scm b/tests/packages.scm
index 1dd7b91ae8..b439183eba 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -94,7 +94,7 @@
                    ("d" ,d) ("d/x" "something.drv"))
                  (pk 'x (package-transitive-inputs e))))))
 
-(test-skip (if (not %store) 4 0))
+(test-skip (if (not %store) 5 0))
 
 (test-assert "return values"
   (let-values (((drv-path drv)
@@ -196,6 +196,13 @@
            (equal? x (collect (package-derivation %store b)))
            (equal? x (collect (package-derivation %store c)))))))
 
+(test-assert "package-cross-derivation"
+  (let-values (((drv-path drv)
+                (package-cross-derivation %store (dummy-package "p")
+                                          "mips64el-linux-gnu")))
+    (and (derivation-path? drv-path)
+         (derivation? drv))))
+
 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
   (test-skip 1))
 (test-assert "GNU Make, bootstrap"