summaryrefslogtreecommitdiff
path: root/guix/packages.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-10-05 16:32:25 +0200
committerLudovic Courtès <ludo@gnu.org>2014-10-05 21:58:42 +0200
commitd3d337d2d8f7152cb9ff3724f1cf240ce5ea5be2 (patch)
tree4b1c5c20515e88fdecf1626673d1f9864942ab1f /guix/packages.scm
parentb4469d8c12905f07a6825654bc3313beb0563cad (diff)
build-system: Bags record their system and target.
* guix/build-system.scm (<bag>)[system, target]: New fields. (make-bag): Add #:system parameter and pass it to LOWER. * gnu/packages/bootstrap.scm (make-raw-bag): Initialize 'system' field. * guix/build-system/cmake.scm (lower): Likewise. * guix/build-system/perl.scm (lower): Likewise. * guix/build-system/python.scm (lower): Likewise. * guix/build-system/ruby.scm (lower): Likewise. * guix/build-system/trivial.scm (lower): Likewise. * guix/build-system/gnu.scm (lower): Initialize 'system' and 'target' fields. * guix/packages.scm (bag->derivation, bag->cross-derivation): New procedures. (package-derivation, package-cross-derivation): Use 'bag->derivation'. * tests/packages.scm ("search paths"): Initialize 'system' and 'target' fields. ("package->bag", "package->bag, cross-compilation", "bag->derivation", "bag->derivation, cross-compilation"): New tests.
Diffstat (limited to 'guix/packages.scm')
-rw-r--r--guix/packages.scm129
1 files changed, 72 insertions, 57 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 47cd6b95bb..a5b886a403 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -95,6 +95,7 @@
package-cross-build-system-error?
package->bag
+ bag->derivation
bag-transitive-inputs
bag-transitive-host-inputs
bag-transitive-build-inputs
@@ -629,6 +630,7 @@ and return it."
args inputs propagated-inputs native-inputs self-native-input?
outputs)
(or (make-bag build-system (package-full-name package)
+ #:system system
#:target target
#:source source
#:inputs (append (inputs)
@@ -647,6 +649,72 @@ and return it."
(&package-error
(package package))))))))))
+(define* (bag->derivation store bag
+ #:optional context)
+ "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
+a package object describing the context in which the call occurs, for improved
+error reporting."
+ (if (bag-target bag)
+ (bag->cross-derivation store bag)
+ (let* ((system (bag-system bag))
+ (inputs (bag-transitive-inputs bag))
+ (input-drvs (map (cut expand-input store context <> system)
+ inputs))
+ (paths (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-native-search-paths
+ p))
+ (_ '()))
+ inputs))))
+
+ (apply (bag-build bag)
+ store (bag-name bag) input-drvs
+ #:search-paths paths
+ #:outputs (bag-outputs bag) #:system system
+ (bag-arguments bag)))))
+
+(define* (bag->cross-derivation store bag
+ #:optional context)
+ "Return the derivation to build BAG, which is actually a cross build.
+Optionally, CONTEXT can be a package object denoting the context of the call.
+This is an internal procedure."
+ (let* ((system (bag-system bag))
+ (target (bag-target bag))
+ (host (bag-transitive-host-inputs bag))
+ (host-drvs (map (cut expand-input store context <> system target)
+ host))
+ (target* (bag-transitive-target-inputs bag))
+ (target-drvs (map (cut expand-input store context <> system)
+ target*))
+ (build (bag-transitive-build-inputs bag))
+ (build-drvs (map (cut expand-input store context <> system)
+ build))
+ (all (append build target* host))
+ (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 (bag-build bag)
+ store (bag-name bag)
+ #:native-drvs build-drvs
+ #:target-drvs (append host-drvs target-drvs)
+ #:search-paths paths
+ #:native-search-paths npaths
+ #:outputs (bag-outputs bag)
+ #:system system #:target target
+ (bag-arguments bag))))
+
(define* (package-derivation store package
#:optional (system (%current-system)))
"Return the <derivation> object of PACKAGE for SYSTEM."
@@ -655,69 +723,16 @@ and return it."
;; because some derivations, such as the implicit inputs of the GNU build
;; system, will be queried many, many times in a row.
(cached package system
- (let* ((bag (package->bag package system #f))
- (inputs (bag-transitive-inputs bag))
- (input-drvs (map (cut expand-input
- store package <> system)
- inputs))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- inputs))))
-
- (apply (bag-build bag)
- store (bag-name bag)
- input-drvs
- #:search-paths paths
- #:outputs (bag-outputs bag) #:system system
- (bag-arguments bag)))))
+ (bag->derivation store (package->bag package system #f)
+ package)))
(define* (package-cross-derivation store package target
#:optional (system (%current-system)))
"Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
system identifying string)."
(cached package (cons system target)
- (let* ((bag (package->bag package system target))
- (host (bag-transitive-host-inputs bag))
- (host-drvs (map (cut expand-input
- store package <>
- system target)
- host))
- (target* (bag-transitive-target-inputs bag))
- (target-drvs (map (cut expand-input
- store package <> system)
- target*))
- (build (bag-transitive-build-inputs bag))
- (build-drvs (map (cut expand-input
- store package <> system)
- build))
- (all (append build target* host))
- (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 (bag-build bag)
- store (bag-name bag)
- #:native-drvs build-drvs
- #:target-drvs (append host-drvs target-drvs)
- #:search-paths paths
- #:native-search-paths npaths
- #:outputs (bag-outputs bag)
- #:system system #:target target
- (bag-arguments bag)))))
+ (bag->derivation store (package->bag package system target)
+ package)))
(define* (package-output store package
#:optional (output "out") (system (%current-system)))