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.

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

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
+;; "Bags" are low-level representations of "packages".  The system and target
-;; build/host/target in the sense of the GNU tool chain (info "(autoconf)
+;; of a bag is fixed when it's created.  This is because build systems may
-;; Specifying Target Triplets").
+;; 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

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

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

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

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

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

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

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,18 +649,16 @@ and return it."
                        (&package-error
                         (package package))))))))))
 
-(define* (package-derivation store package
+(define* (bag->derivation store bag
-                             #:optional (system (%current-system)))
+                          #:optional context)
-  "Return the <derivation> object of PACKAGE for SYSTEM."
+  "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
-  ;; Compute the derivation and cache the result.  Caching is important
+error reporting."
-  ;; because some derivations, such as the implicit inputs of the GNU build
+  (if (bag-target bag)
-  ;; system, will be queried many, many times in a row.
+      (bag->cross-derivation store bag)
-  (cached package system
+      (let* ((system     (bag-system bag))
-          (let* ((bag        (package->bag package system #f))
              (inputs     (bag-transitive-inputs bag))
-                 (input-drvs (map (cut expand-input
+             (input-drvs (map (cut expand-input store context <> system)
-                                       store package <> system)
                               inputs))
              (paths      (delete-duplicates
                           (append-map (match-lambda
@@ -669,30 +669,26 @@ and return it."
                                       inputs))))
 
         (apply (bag-build bag)
-                   store (bag-name bag)
+               store (bag-name bag) input-drvs
-                   input-drvs
                #:search-paths paths
                #:outputs (bag-outputs bag) #:system system
                (bag-arguments bag)))))
 
-(define* (package-cross-derivation store package target
+(define* (bag->cross-derivation store bag
-                                   #:optional (system (%current-system)))
+                                #:optional context)
-  "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
+  "Return the derivation to build BAG, which is actually a cross build.
-system identifying string)."
+Optionally, CONTEXT can be a package object denoting the context of the call.
-  (cached package (cons system target)
+This is an internal procedure."
-          (let* ((bag         (package->bag package system target))
+  (let* ((system      (bag-system bag))
+         (target      (bag-target bag))
          (host        (bag-transitive-host-inputs bag))
-                 (host-drvs   (map (cut expand-input
+         (host-drvs   (map (cut expand-input store context <> system target)
-                                        store package <>
-                                        system target)
                            host))
          (target*     (bag-transitive-target-inputs bag))
-                 (target-drvs (map (cut expand-input
+         (target-drvs (map (cut expand-input store context <> system)
-                                        store package <> system)
                            target*))
          (build       (bag-transitive-build-inputs bag))
-                 (build-drvs  (map (cut expand-input
+         (build-drvs  (map (cut expand-input store context <> system)
-                                        store package <> system)
                            build))
          (all         (append build target* host))
          (paths       (delete-duplicates
@@ -717,7 +713,26 @@ system identifying string)."
            #:native-search-paths npaths
            #:outputs (bag-outputs bag)
            #:system system #:target target
-                   (bag-arguments bag)))))
+           (bag-arguments bag))))
+
+(define* (package-derivation store package
+                             #:optional (system (%current-system)))
+  "Return the <derivation> object of PACKAGE for SYSTEM."
+
+  ;; Compute the derivation and cache the result.  Caching is important
+  ;; 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
+          (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)
+          (bag->derivation store (package->bag package system target)
+                           package)))
 
 (define* (package-output store package
                          #:optional (output "out") (system (%current-system)))

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"