63/64: system: vm: Support cross-compilation.

[guix-commits]

mothacehe pushed a commit to branch wip-cross-system
in repository guix.

commit 49f66aef6e9707ebf998f1047bafce090f8a8840
Author: Mathieu Othacehe <address@hidden>
Date:   Wed Aug 21 09:19:58 2019 +0200

    system: vm: Support cross-compilation.
    
    * gnu/system.scm (system-linux-image-file-name): Add support for cross-built
    systems. Remove system argument that was ignored,
    (operating-system-kernel-file): adapt by removing ignored os argument.
    * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add target 
argument,
    move qemu from inputs list to a new native-inputs list and adapt
    set-path-environment-variable call accordingly. Pass target to qemu-command
    and gexp->derivation calls.
    (iso9660-image): Move qemu from inputs to a new native-inputs list and adapt
    set-path-environment-variable accordingly.
    (qemu-image): Add target argument, move qemu from inputs list to a new
    native-inputs list and adapt set-path-environment-variable call
    accordingly. Pass target argument to expression->derivation-in-linux-vm 
call.
---
 gnu/system.scm    | 15 ++++++++-------
 gnu/system/vm.scm | 25 ++++++++++++++++++-------
 2 files changed, 26 insertions(+), 14 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index 485896b..8505911 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -439,20 +439,21 @@ from the initrd."
   "Return the list of swap services for OS."
   (map swap-service (operating-system-swap-devices os)))
 
-(define* (system-linux-image-file-name #:optional (system (%current-system)))
+(define* (system-linux-image-file-name)
   "Return the basename of the kernel image file for SYSTEM."
   ;; FIXME: Evaluate the conditional based on the actual current system.
-  (cond
-   ((string-prefix? "arm" (%current-system)) "zImage")
-   ((string-prefix? "mips" (%current-system)) "vmlinuz")
-   ((string-prefix? "aarch64" (%current-system)) "Image")
-   (else "bzImage")))
+  (let ((target (or (%current-target-system) (%current-system))))
+    (cond
+     ((string-prefix? "arm" target) "zImage")
+     ((string-prefix? "mips" target) "vmlinuz")
+     ((string-prefix? "aarch64" target) "Image")
+     (else "bzImage"))))
 
 (define (operating-system-kernel-file os)
   "Return an object representing the absolute file name of the kernel image of
 OS."
   (file-append (operating-system-kernel os)
-               "/" (system-linux-image-file-name os)))
+               "/" (system-linux-image-file-name)))
 
 (define* (operating-system-directory-base-entries os)
   "Return the basic entries of the 'system' directory of OS for use as the
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 07cee2d..759745c 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -143,7 +143,7 @@
 
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
-                                             (system (%current-system))
+                                             (system (%current-system)) target
                                              (linux linux-libre)
                                              initrd
                                              (qemu qemu-minimal)
@@ -214,7 +214,8 @@ made available under the /xchg CIFS share."
               (use-modules (guix build utils)
                            (gnu build vm))
 
-              (let* ((inputs  '#$(list qemu (canonical-package coreutils)))
+              (let* ((inputs  '#$(list (canonical-package coreutils)))
+                     (native-inputs '#+(list qemu))
                      (linux   (string-append #$linux "/"
                                              #$(system-linux-image-file-name)))
                      (initrd  #$initrd)
@@ -222,16 +223,19 @@ made available under the /xchg CIFS share."
                      (graphs  '#$(match references-graphs
                                    (((graph-files . _) ...) graph-files)
                                    (_ #f)))
+                     (target  #$(or (%current-target-system) 
(%current-system)))
                      (size    #$(if (eq? 'guess disk-image-size)
                                     #~(+ (* 70 (expt 2 20)) ;ESP
                                          (estimated-partition-size graphs))
                                     disk-image-size)))
 
-                (set-path-environment-variable "PATH" '("bin") inputs)
+                (set-path-environment-variable "PATH" '("bin")
+                                               (append inputs native-inputs))
 
                 (load-in-linux-vm loader
                                   #:output #$output
                                   #:linux linux #:initrd initrd
+                                  #:qemu (qemu-command target)
                                   #:memory-size #$memory-size
                                   #:make-disk-image? #$make-disk-image?
                                   #:single-file-output? #$single-file-output?
@@ -248,6 +252,7 @@ made available under the /xchg CIFS share."
     (gexp->derivation name builder
                       ;; TODO: Require the "kvm" feature.
                       #:system system
+                      #:target target
                       #:env-vars env-vars
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs)))
@@ -299,9 +304,10 @@ INPUTS is a list of inputs (as for packages)."
            (setlocale LC_ALL "en_US.utf8")
 
            (let ((inputs
-                  '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
+                  '#$(append (list parted e2fsprogs dosfstools xorriso)
                              (map canonical-package
                                   (list sed grep coreutils findutils gawk))))
+                 (native-inputs '#+(list qemu))
 
 
                  (graphs     '#$(match inputs
@@ -315,7 +321,8 @@ INPUTS is a list of inputs (as for packages)."
                             ((name thing output) `(,thing ,output)))
                           inputs)))
 
-             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+             (set-path-environment-variable "PATH" '("bin" "sbin")
+                                            (append inputs native-inputs))
              (make-iso9660-image #$xorriso
                                  '#$grub-mkrescue-environment
                                  #$(bootloader-package bootloader)
@@ -346,6 +353,7 @@ INPUTS is a list of inputs (as for packages)."
 (define* (qemu-image #:key
                      (name "qemu-image")
                      (system (%current-system))
+                     (target (%current-target-system))
                      (qemu qemu-minimal)
                      (disk-image-size 'guess)
                      (disk-image-format "qcow2")
@@ -404,9 +412,10 @@ system."
            (setlocale LC_ALL "en_US.utf8")
 
            (let ((inputs
-                  '#$(append (list qemu parted e2fsprogs dosfstools)
+                  '#$(append (list util-linux parted e2fsprogs dosfstools)
                              (map canonical-package
                                   (list sed grep coreutils findutils gawk))))
+                 (native-inputs '#+(list qemu))
 
                  ;; This variable is unused but allows us to add INPUTS-TO-COPY
                  ;; as inputs.
@@ -416,7 +425,8 @@ system."
                             ((name thing output) `(,thing ,output)))
                           inputs)))
 
-             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+             (set-path-environment-variable "PATH" '("bin" "sbin")
+                                            (append inputs native-inputs))
 
              (let* ((graphs     '#$(match inputs
                                      (((names . _) ...)
@@ -483,6 +493,7 @@ system."
                                      #:bootloader-installer
                                      #$(bootloader-installer bootloader)))))))
    #:system system
+   #:target target
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:disk-image-format disk-image-format