diff options
| -rw-r--r-- | gnu/packages/bootstrap.scm | 4 | ||||
| -rw-r--r-- | guix/build-system.scm | 18 | ||||
| -rw-r--r-- | guix/build-system/cmake.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/perl.scm | 4 | ||||
| -rw-r--r-- | guix/build-system/python.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/ruby.scm | 3 | ||||
| -rw-r--r-- | guix/build-system/trivial.scm | 3 | ||||
| -rw-r--r-- | guix/packages.scm | 129 | ||||
| -rw-r--r-- | tests/packages.scm | 36 |
10 files changed, 137 insertions, 69 deletions
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index efa8cd89eb..315e8cf21e 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -198,9 +198,11 @@ $out/bin/guile --version~%" #:inputs `((,bash) (,builder))))) (define* (make-raw-bag name - #:key source inputs native-inputs outputs target) + #:key source inputs native-inputs outputs + system target) (bag (name name) + (system system) (build-inputs inputs) (build raw-build))) diff --git a/guix/build-system.scm b/guix/build-system.scm index f185d5704f..4174972b98 100644 --- a/guix/build-system.scm +++ b/guix/build-system.scm @@ -28,6 +28,8 @@ bag bag? bag-name + bag-system + bag-target bag-build-inputs bag-host-inputs bag-target-inputs @@ -43,12 +45,19 @@ (description build-system-description) ; short description (lower build-system-lower)) ; args ... -> bags -;; "Bags" are low-level representations of "packages". Here we use -;; build/host/target in the sense of the GNU tool chain (info "(autoconf) -;; Specifying Target Triplets"). +;; "Bags" are low-level representations of "packages". The system and target +;; of a bag is fixed when it's created. This is because build systems may +;; choose inputs as a function of the system and target. (define-record-type* <bag> bag %make-bag bag? (name bag-name) ;string + + (system bag-system) ;string + (target bag-target ;string | #f + (default #f)) + + ;; Here we use build/host/target in the sense of the GNU tool chain (info + ;; "(autoconf) Specifying Target Triplets"). (build-inputs bag-build-inputs ;list of packages (default '())) (host-inputs bag-host-inputs ;list of packages @@ -72,7 +81,7 @@ (define* (make-bag build-system name #:key source (inputs '()) (native-inputs '()) (outputs '()) (arguments '()) - target) + system target) "Ask BUILD-SYSTEM to return a 'bag' for NAME, with the given SOURCE, INPUTS, NATIVE-INPUTS, OUTPUTS, and additional ARGUMENTS. If TARGET is not #f, it must be a string with the GNU triplet of a cross-compilation target. @@ -82,6 +91,7 @@ intermediate representation just above derivations." (match build-system (($ <build-system> _ description lower) (apply lower name + #:system system #:source source #:inputs inputs #:native-inputs native-inputs diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 0e750c0e11..85acc2d0b3 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -43,7 +43,7 @@ (module-ref module 'cmake))) (define* (lower name - #:key source inputs native-inputs outputs target + #:key source inputs native-inputs outputs system target (cmake (default-cmake)) #:allow-other-keys #:rest arguments) @@ -54,6 +54,7 @@ (and (not target) ;XXX: no cross-compilation (bag (name name) + (system system) (host-inputs `(,@(if source `(("source" ,source)) '()) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index c58dac10bb..d2c29d44b5 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -210,7 +210,7 @@ standard packages used as implicit inputs of the GNU build system." (define* (lower name #:key source inputs native-inputs outputs target (implicit-inputs? #t) (implicit-cross-inputs? #t) - (strip-binaries? #t) + (strip-binaries? #t) system #:allow-other-keys #:rest arguments) "Return a bag for NAME from the given arguments." @@ -221,6 +221,7 @@ standard packages used as implicit inputs of the GNU build system." (bag (name name) + (system system) (target target) (build-inputs `(,@(if source `(("source" ,source)) '()) diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 6cf8cbe13a..1a968f4150 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -43,7 +43,8 @@ (module-ref module 'perl))) (define* (lower name - #:key source inputs native-inputs outputs target + #:key source inputs native-inputs outputs + system target (perl (default-perl)) #:allow-other-keys #:rest arguments) @@ -54,6 +55,7 @@ (and (not target) ;XXX: no cross-compilation (bag (name name) + (system system) (host-inputs `(,@(if source `(("source" ,source)) '()) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index e28573bb05..3cd537c752 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -93,7 +93,7 @@ prepended to the name." (cut package-with-explicit-python <> (default-python2) "python-" "python2-")) (define* (lower name - #:key source inputs native-inputs outputs target + #:key source inputs native-inputs outputs system target (python (default-python)) #:allow-other-keys #:rest arguments) @@ -104,6 +104,7 @@ prepended to the name." (and (not target) ;XXX: no cross-compilation (bag (name name) + (system system) (host-inputs `(,@(if source `(("source" ,source)) '()) diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 8312629fd8..e4e115f657 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -35,7 +35,7 @@ (module-ref ruby 'ruby))) (define* (lower name - #:key source inputs native-inputs outputs target + #:key source inputs native-inputs outputs system target (ruby (default-ruby)) #:allow-other-keys #:rest arguments) @@ -46,6 +46,7 @@ (and (not target) ;XXX: no cross-compilation (bag (name name) + (system system) (host-inputs `(,@(if source `(("source" ,source)) '()) diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 1b07f14e63..839042aa2a 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -35,11 +35,12 @@ (package-derivation store guile system))))) (define* (lower name - #:key source inputs native-inputs outputs target + #:key source inputs native-inputs outputs system target guile builder modules) "Return a bag for NAME." (bag (name name) + (system system) (host-inputs `(,@(if source `(("source" ,source)) '()) 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))) diff --git a/tests/packages.scm b/tests/packages.scm index 6deb21c331..2a87f3f15d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -281,9 +281,11 @@ (s (build-system (name 'raw) (description "Raw build system with direct store access") - (lower (lambda* (name #:key source inputs #:allow-other-keys) + (lower (lambda* (name #:key source inputs system target + #:allow-other-keys) (bag (name name) + (system system) (target target) (build-inputs inputs) (build (lambda* (store name inputs @@ -339,6 +341,38 @@ (package-cross-derivation %store p "mips64el-linux-gnu") #f))) +(test-equal "package->bag" + `("foo86-hurd" #f (,(package-source gnu-make)) + (,(canonical-package glibc)) (,(canonical-package coreutils))) + (let ((bag (package->bag gnu-make "foo86-hurd"))) + (list (bag-system bag) (bag-target bag) + (assoc-ref (bag-build-inputs bag) "source") + (assoc-ref (bag-build-inputs bag) "libc") + (assoc-ref (bag-build-inputs bag) "coreutils")))) + +(test-equal "package->bag, cross-compilation" + `(,(%current-system) "foo86-hurd" + (,(package-source gnu-make)) + (,(canonical-package glibc)) (,(canonical-package coreutils))) + (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd"))) + (list (bag-system bag) (bag-target bag) + (assoc-ref (bag-build-inputs bag) "source") + (assoc-ref (bag-build-inputs bag) "libc") + (assoc-ref (bag-build-inputs bag) "coreutils")))) + +(test-assert "bag->derivation" + (let ((bag (package->bag gnu-make)) + (drv (package-derivation %store gnu-make))) + (parameterize ((%current-system "foox86-hurd")) ;should have no effect + (equal? drv (bag->derivation %store bag))))) + +(test-assert "bag->derivation, cross-compilation" + (let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu")) + (drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu"))) + (parameterize ((%current-system "foox86-hurd") ;should have no effect + (%current-target-system "foo64-linux-gnu")) + (equal? drv (bag->derivation %store bag))))) + (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)) (test-skip 1)) (test-assert "GNU Make, bootstrap" |