10 files changed, 137 insertions(+), 69 deletions(-)

M gnu/packages/bootstrap.scm
M guix/build-system.scm
M guix/build-system/cmake.scm
M guix/build-system/gnu.scm
M guix/build-system/perl.scm
M guix/build-system/python.scm
M guix/build-system/ruby.scm
M guix/build-system/trivial.scm
M guix/packages.scm
M tests/packages.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)))
 

@@ 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

@@ 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))
                               '())

@@ 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))
                           '())

@@ 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))
                               '())

@@ 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))
                               '())

@@ 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))
                               '())

@@ 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))
                          '())

@@ 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)))

@@ 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"