system: vm: Build vm-image using native qemu, for the Hurd.series-4069

Cross-building a vm-image is usually done using a cross-qemu, e.g, qemu-ARM,
because, e.g., a native, x86_64 Grub cannot install an armhf-Grub.  That
solution does not work for the Hurd, as there is no qemu-HURD.

This patch enables cross building vm-images for the Hurd using a native qemu
vm.

* gnu/system/vm.scm (expression->derivation-in-linux-vm): Run native
qemu-command; use native linux, initrd, bootloader-package and
bootloader-installer, for the Hurd.
[preserve-target]: New helper to install cross-packages into the native vm.
* gnu/bootloader/grub.scm (eye-candy): Use native font.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>

2 files changed, 60 insertions, 25 deletions

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index bb40c551a7..ccf70b3785 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -207,8 +207,8 @@ else
   set menu_color_highlight=white/blue
 fi~%"
                  #$setup-gfxterm-body
-                 #$(grub-root-search store-device font-file)
-                 #$(setup-gfxterm config font-file)
+                 #+(grub-root-search store-device font-file)
+                 #+(setup-gfxterm config font-file)
                  #$(grub-setup-io config)
 
                  #$image
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b343141c18..245ecc73b3 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -181,29 +182,46 @@ made available under the /xchg CIFS share.
 SUBSTITUTABLE? determines whether the returned derivation should be marked as
 substitutable."
   (define user-builder
-    (program-file "builder-in-linux-vm" exp))
+    (scheme-file "builder-in-linux-vm" exp))
+
+  (define (preserve-target obj)
+    (if target
+        (with-parameters ((%current-target-system target))
+          obj)
+        obj))
+
+  (define-syntax-rule (check predicate)
+    (let-system (system target)
+      (predicate (or target system))))
 
   (define loader
-    ;; Invoke USER-BUILDER instead using 'primitive-load'.  The reason for
-    ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured
-    ;; Guile, which it couldn't do using the statically-linked guile used in
-    ;; the initrd.  See example at
+    ;; Instead of using 'primitive-load', evaluate USER-BUILDER in a
+    ;; full-featured Guile so it can use dlopen stuff, which it couldn't do
+    ;; using the statically-linked guile used in the initrd.  See example at
     ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>.
     (program-file "linux-vm-loader"
-                  ;; Communicate USER-BUILDER's exit status via /xchg so that
-                  ;; the host can distinguish between success, failure, and
-                  ;; kernel panic.
-                  #~(let ((status (system* #$user-builder)))
+                  ;; When cross-compiling, USER-BUILDER refers to the target
+                  ;; (cross-compiled) system.  Preserve that, even though
+                  ;; LOADER itself is executed as a native program.
+                  #~(let* ((guile #$(if (check hurd-triplet?)
+                                        #~#+(file-append (default-guile)
+                                                         "/bin/guile")
+                                        (file-append (default-guile)
+                                                     "/bin/guile")))
+                           (status (system* guile "--no-auto-compile"
+                                            #$(if (check hurd-triplet?)
+                                                  (preserve-target user-builder)
+                                                  user-builder))))
+
+                      ;; Communicate USER-BUILDER's exit status via /xchg so
+                      ;; that the host can distinguish between success,
+                      ;; failure, and kernel panic.
                       (call-with-output-file "/xchg/.exit-status"
                         (lambda (port)
                           (write status port)))
                       (sync)
                       (reboot))))
 
-  (define-syntax-rule (check predicate)
-    (let-system (system target)
-      (predicate (or target system))))
-
   (let ((initrd (or initrd
                     (base-initrd file-systems
                                  #:on-error 'backtrace
@@ -227,10 +245,16 @@ substitutable."
 
               (let* ((native-inputs
                       '#+(list qemu (canonical-package coreutils)))
-                     (linux   (string-append #$linux "/"
-                                             #$(system-linux-image-file-name)))
-                     (initrd  #$initrd)
-                     (loader  #$loader)
+
+                     (loader  #$(if (check hurd-triplet?) #~#+loader loader))
+                     (linux   #$(if (check hurd-triplet?)
+                                    #~(string-append
+                                       #+linux "/"
+                                       #+(system-linux-image-file-name))
+                                    #~(string-append
+                                       #$linux "/"
+                                       #$(system-linux-image-file-name))))
+                     (initrd  #$(if (check hurd-triplet?) #~#+initrd initrd))
                      (graphs  '#$(match references-graphs
                                    (((graph-files . _) ...) graph-files)
                                    (_ #f)))
@@ -246,7 +270,10 @@ substitutable."
                 (load-in-linux-vm loader
                                   #:output #$output
                                   #:linux linux #:initrd initrd
-                                  #:qemu (qemu-command target)
+                                  #:qemu #$(if (or (not target)
+                                                   (check hurd-triplet?))
+                                               (qemu-command)
+                                               (qemu-command target))
                                   #:memory-size #$memory-size
                                   #:make-disk-image? #$make-disk-image?
                                   #:single-file-output? #$single-file-output?
@@ -349,9 +376,13 @@ system that is passed to 'populate-root-file-system'."
            (setlocale LC_ALL "en_US.utf8")
 
            (let ((inputs
-                  '#$(append (list parted e2fsprogs dosfstools)
-                             (map canonical-package
-                                  (list sed grep coreutils findutils gawk))))
+                  '#$(if (hurd-target?)
+                         #~#+(append (list parted e2fsprogs dosfstools)
+                                     (map canonical-package
+                                          (list sed grep coreutils findutils gawk)))
+                         (append (list parted e2fsprogs dosfstools)
+                                 (map canonical-package
+                                      (list sed grep coreutils findutils gawk)))))
 
                  ;; This variable is unused but allows us to add INPUTS-TO-COPY
                  ;; as inputs.
@@ -426,12 +457,16 @@ system that is passed to 'populate-root-file-system'."
                                      #:partitions partitions
                                      #:grub-efi grub-efi
                                      #:bootloader-package
-                                     #$(bootloader-package bootloader)
+                                     #$(if (hurd-target?)
+                                         #~#+(bootloader-package bootloader)
+                                         (bootloader-package bootloader))
                                      #:bootcfg #$bootcfg-drv
                                      #:bootcfg-location
                                      #$(bootloader-configuration-file bootloader)
                                      #:bootloader-installer
-                                     #$(bootloader-installer bootloader)))))))
+                                     #$(if (hurd-target?)
+                                           #~#+(bootloader-installer bootloader)
+                                           (bootloader-installer bootloader))))))))
    #:system system
    #:target target
    #:make-disk-image? #t