summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-05-24 22:21:24 +0200
committerLudovic Courtès <ludo@gnu.org>2013-05-24 22:30:58 +0200
commit9c1edabd8b95d698ba995653d465fcb70cd2409b (patch)
tree585fead8a546f2e6d9c9827434b0fb24807241de
parent17bb886ff42afe7caa7b89878a563243239f9698 (diff)
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'.
-rw-r--r--doc/guix.texi17
-rw-r--r--guix/packages.scm71
-rw-r--r--guix/utils.scm6
-rw-r--r--tests/packages.scm9
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"