[bug#41350] [PATCH v2 3/3] system: vm: Build vm-image using native qemu, for the Hurd.

[Ludovic Courtès]

Hi!

Mathieu Othacehe <othacehe@gnu.org> skribis:

>>   1. When cross-compiling, can the ‘qemu-image’ procedure to its job by
>>      running exclusively native software (in particular using a native
>>      QEMU, native kernel, etc.)?
>
> I think the answer is yes, but I raised a concern about being able to
> run grub-install from an ARM system to build a cross-compiled x86-64
> system (for instance).
>
> For now, running this command shows:
>
> ls $(guix build --system=aarch64-linux grub)/lib/grub/
> arm64-efi
>
> So, the native aarch64-linux is only able to install itself on the same
> system. I think can be fixed though (same as for grub-hybrid package).
>
>> As for (2), I’d say that when cross-compiling, it should just run native
>> software but simply preserve references to cross-compiled software,
>> which is what janneke’s patch does.
>
> Yes, I agree.

So it took me the whole day, but I ended up with the following patches
addressing these two points.  With that on master, I can do:

  guix system vm --target=arm-linux-gnueabihf --no-grafts \
    gnu/system/examples/bare-bones.tmpl

and get a usable script that spawns an ARM VM (I still need to add ‘-M
virt -nographic’ and remove ‘-enable-kvm’, but that’s a secondary
issue.)

Likewise, this produces what looks like a valid image, except probably
for the bootloader (I used GRUB in bare-bones, which didn’t complain,
but the result doesn’t work):

  guix system vm-image --target=arm-linux-gnueabihf …

Thoughts?

I’ll see if I can test it with ‘wip-hurd-vm’ on top but I’m not sure
I’ll do it before the week-end.

> However, I think I found a way to install Grub, without root
> permissions, from the host system (see:
> https://lists.gnu.org/archive/html/guix-patches/2020-05/msg00988.html).

Yay!

> This should allow to deprecate the whole (gnu system vm) module.

Yeah, using the new image API will be nicer.  We still need to keep some
of the API in (guix system vm), at least for the ‘guix system vm’
command.

Thanks,
Ludo’.

>From 1ccd6f8e853be17fa4ec244a660fa53ffcec979f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 17:40:14 +0200
Subject: [PATCH 1/7] system: 'system-linux-image-file-name' takes an optional
 parameter.

* gnu/system.scm (system-linux-image-file-name): Make 'target' an
optional parameter.
---
 gnu/system.scm | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index d929187695..ab0a6dfc33 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -466,15 +466,15 @@ 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)
-  "Return the basename of the kernel image file for SYSTEM."
-  ;; FIXME: Evaluate the conditional based on the actual current system.
-  (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* (system-linux-image-file-name #:optional
+                                       (target (or (%current-target-system)
+                                                   (%current-system))))
+  "Return the basename of the kernel image file for TARGET."
+  (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
-- 
2.26.2

>From 56d8d921199bfdf151d899639052f579f24fdd00 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 23:04:48 +0200
Subject: [PATCH 2/7] vm: 'expression->derivation-in-linux-vm' always returns a
 native build.

* gnu/system/vm.scm (expression->derivation-in-linux-vm): Remove #:target.
[builder]: Use #+.  Don't pass #:target-arm32? and #:target-aarch64? to
'load-in-linux-vm'.
Pass #:target #f to 'gexp->derivation'.
(qemu-image): Adjust accordingly.
* gnu/build/vm.scm (load-in-linux-vm): Remove #:target-aarch64?
and #:target-arm32?.  Define them as local variables.
---
 gnu/build/vm.scm  | 11 ++++++++---
 gnu/system/vm.scm | 16 +++++++---------
 2 files changed, 15 insertions(+), 12 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 433b5a7e8d..0f0ceae18f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -84,8 +84,6 @@
                            linux initrd
                            make-disk-image?
                            single-file-output?
-                           target-arm32?
-                           target-aarch64?
                            (disk-image-size (* 100 (expt 2 20)))
                            (disk-image-format "qcow2")
                            (references-graphs '()))
@@ -101,7 +99,14 @@ access it via /dev/hda.
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
 
-  (define target-arm? (or target-arm32? target-aarch64?))
+  (define target-arm32?
+    (string-prefix? "arm-" %host-type))
+
+  (define target-aarch64?
+    (string-prefix? "aarch64-" %host-type))
+
+  (define target-arm?
+    (or target-arm32? target-aarch64?))
 
   (define arch-specific-flags
     `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3e483fd86c..d737a5e4ec 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -141,7 +141,7 @@
 
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
-                                             (system (%current-system)) target
+                                             (system (%current-system))
                                              (linux linux-libre)
                                              initrd
                                              (qemu qemu-minimal)
@@ -226,10 +226,11 @@ substitutable."
 
               (let* ((native-inputs
                       '#+(list qemu (canonical-package coreutils)))
-                     (linux   (string-append #$linux "/"
-                                             #$(system-linux-image-file-name)))
-                     (initrd  #$initrd)
-                     (loader  #$loader)
+                     (linux   (string-append
+                               #+linux "/"
+                               #+(system-linux-image-file-name system)))
+                     (initrd  #+initrd)
+                     (loader  #+loader)
                      (graphs  '#$(match references-graphs
                                    (((graph-files . _) ...) graph-files)
                                    (_ #f)))
@@ -249,8 +250,6 @@ substitutable."
                                   #:memory-size #$memory-size
                                   #:make-disk-image? #$make-disk-image?
                                   #:single-file-output? #$single-file-output?
-                                  #:target-arm32? #$(check target-arm32?)
-                                  #:target-aarch64? #$(check target-aarch64?)
                                   #:disk-image-format #$disk-image-format
                                   #:disk-image-size size
                                   #:references-graphs graphs))))))
@@ -258,7 +257,7 @@ substitutable."
     (gexp->derivation name builder
                       ;; TODO: Require the "kvm" feature.
                       #:system system
-                      #:target target
+                      #:target #f             ;EXP is always executed natively
                       #:env-vars env-vars
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs
@@ -430,7 +429,6 @@ system that is passed to 'populate-root-file-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
-- 
2.26.2

>From a2b70d97aa80f70cba56d419470ee8d2221dcc1e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 23:08:15 +0200
Subject: [PATCH 3/7] vm: 'qemu-image' uses the native partitioning tools and
 bootloader.

* gnu/system/vm.scm (qemu-image): Use #+ for Parted, the bootloader, etc.
---
 gnu/system/vm.scm | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index d737a5e4ec..c7767db9df 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -345,7 +345,7 @@ system that is passed to 'populate-root-file-system'."
            (setlocale LC_ALL "en_US.utf8")
 
            (let ((inputs
-                  '#$(append (list parted e2fsprogs dosfstools)
+                  '#+(append (list parted e2fsprogs dosfstools)
                              (map canonical-package
                                   (list sed grep coreutils findutils gawk))))
 
@@ -422,12 +422,12 @@ system that is passed to 'populate-root-file-system'."
                                      #:partitions partitions
                                      #:grub-efi grub-efi
                                      #:bootloader-package
-                                     #$(bootloader-package bootloader)
+                                     #+(bootloader-package bootloader)
                                      #:bootcfg #$bootcfg-drv
                                      #:bootcfg-location
                                      #$(bootloader-configuration-file 
bootloader)
                                      #:bootloader-installer
-                                     #$(bootloader-installer bootloader)))))))
+                                     #+(bootloader-installer bootloader)))))))
    #:system system
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
-- 
2.26.2

>From db7a12bf54585c8979602956a03fbb6502381dcd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 28 May 2020 00:37:33 +0200
Subject: [PATCH 4/7] vm: 'qemu-image' preserves the cross-compilation target
 of the OS.

* gnu/system/vm.scm (qemu-image)[preserve-target, inputs*]: New variables.
In gexp, use INPUTS* instead of INPUTS.  Wrap OS and BOOTCFG-DRV in
'preserve-target'.  Pass INPUTS* instead of INPUTS as the #:references-graphs.
---
 gnu/system/vm.scm | 23 +++++++++++++++++++----
 1 file changed, 19 insertions(+), 4 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index c7767db9df..991ea2d837 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -317,6 +317,21 @@ system that is passed to 'populate-root-file-system'."
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
+  (define preserve-target
+    (if target
+        (lambda (obj)
+          (with-parameters ((%current-target-system target))
+            obj))
+        identity))
+
+  (define inputs*
+    (map (match-lambda
+           ((name thing)
+            `(,name ,(preserve-target thing)))
+           ((name thing output)
+            `(,name ,(preserve-target thing) ,output)))
+         inputs))
+
   (expression->derivation-in-linux-vm
    name
    (with-extensions gcrypt-sqlite3&co
@@ -355,7 +370,7 @@ system that is passed to 'populate-root-file-system'."
                   '#$(map (match-lambda
                             ((name thing) thing)
                             ((name thing output) `(,thing ,output)))
-                          inputs)))
+                          inputs*)))
 
              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 
@@ -367,7 +382,7 @@ system that is passed to 'populate-root-file-system'."
                                  #:closures graphs
                                  #:copy-closures? #$copy-inputs?
                                  #:register-closures? #$register-closures?
-                                 #:system-directory #$os
+                                 #:system-directory #$(preserve-target os)
 
                                  #:make-device-nodes
                                  #$(match device-nodes
@@ -423,7 +438,7 @@ system that is passed to 'populate-root-file-system'."
                                      #:grub-efi grub-efi
                                      #:bootloader-package
                                      #+(bootloader-package bootloader)
-                                     #:bootcfg #$bootcfg-drv
+                                     #:bootcfg #$(preserve-target bootcfg-drv)
                                      #:bootcfg-location
                                      #$(bootloader-configuration-file 
bootloader)
                                      #:bootloader-installer
@@ -432,7 +447,7 @@ system that is passed to 'populate-root-file-system'."
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:disk-image-format disk-image-format
-   #:references-graphs inputs
+   #:references-graphs inputs*
    #:substitutable? substitutable?))
 
 (define* (system-docker-image os
-- 
2.26.2

>From a9270c1261b747dc9a82b52d1ce38314862c51cd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 23:09:49 +0200
Subject: [PATCH 5/7] vm: <virtual-machine> compiler honors system and target.

* gnu/system/vm.scm (system-qemu-image/shared-store): Add #:system
and #:target.  Pass it down.
(system-qemu-image/shared-store-script): Likewise.
(virtual-machine-compiler): Likewise.
---
 gnu/system/vm.scm | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 991ea2d837..05f3986aca 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -764,6 +764,8 @@ environment with the store shared with the host.  MAPPINGS 
is a list of
 (define* (system-qemu-image/shared-store
           os
           #:key
+          (system (%current-system))
+          (target (%current-target-system))
           full-boot?
           (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
   "Return a derivation that builds a QEMU image of OS that shares its store
@@ -784,6 +786,8 @@ bootloader refers to: OS kernel, initrd, bootloader data, 
etc."
   ;; This is more than needed (we only need the kernel, initrd, GRUB for its
   ;; font, and the background image), but it's hard to filter that.
   (qemu-image #:os os
+              #:system system
+              #:target target
               #:bootcfg-drv bootcfg
               #:bootloader (bootloader-configuration-bootloader
                             (operating-system-bootloader os))
@@ -824,6 +828,8 @@ with '-virtfs' options for the host file systems listed in 
SHARED-FS."
 
 (define* (system-qemu-image/shared-store-script os
                                                 #:key
+                                                (system (%current-system))
+                                                (target 
(%current-target-system))
                                                 (qemu qemu)
                                                 (graphic? #t)
                                                 (memory-size 256)
@@ -847,6 +853,8 @@ it is mostly useful when FULL-BOOT?  is true."
   (mlet* %store-monad ((os ->  (virtualized-operating-system os mappings 
full-boot?))
                        (image  (system-qemu-image/shared-store
                                 os
+                                #:system system
+                                #:target target
                                 #:full-boot? full-boot?
                                 #:disk-image-size disk-image-size)))
     (define kernel-arguments
@@ -920,10 +928,11 @@ FORWARDINGS is a list of host-port/guest-port pairs."
 
 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
                                                 system target)
-  ;; XXX: SYSTEM and TARGET are ignored.
   (match vm
     (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
      (system-qemu-image/shared-store-script os
+                                            #:system system
+                                            #:target target
                                             #:qemu qemu
                                             #:graphic? graphic?
                                             #:memory-size memory-size
@@ -936,6 +945,8 @@ FORWARDINGS is a list of host-port/guest-port pairs."
                        "user,model=virtio-net-pci,"
                        (port-forwardings->qemu-options forwardings)))))
        (system-qemu-image/shared-store-script os
+                                              #:system system
+                                              #:target target
                                               #:qemu qemu
                                               #:graphic? graphic?
                                               #:memory-size memory-size
-- 
2.26.2

>From dc3f04a9f412045a85ac810f9436648368c36adc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 23:11:14 +0200
Subject: [PATCH 6/7] vm: Shared-store script runs that native QEMU and Bash.

* gnu/system/vm.scm (system-qemu-image/shared-store-script): Use #+ for
QEMU and BASH.
---
 gnu/system/vm.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 05f3986aca..038cce19b6 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -862,7 +862,8 @@ it is mostly useful when FULL-BOOT?  is true."
               #+@(operating-system-kernel-arguments os "/dev/vda1")))
 
     (define qemu-exec
-      #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
+      #~(list #+(file-append qemu "/bin/"
+                             (qemu-command (or target system)))
               #$@(if full-boot?
                      #~()
                      #~("-kernel" #$(operating-system-kernel-file os)
@@ -879,7 +880,7 @@ it is mostly useful when FULL-BOOT?  is true."
       #~(call-with-output-file #$output
           (lambda (port)
             (format port "#!~a~% exec ~a \"$@\"~%"
-                    #$(file-append bash "/bin/sh")
+                    #+(file-append bash "/bin/sh")
                     (string-join #$qemu-exec " "))
             (chmod port #o555))))
 
-- 
2.26.2

>From 6e936131ca85aba24f82d35c4616afe835ac7da5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 May 2020 23:57:41 +0200
Subject: [PATCH 7/7] gnu: guile-static: Disable JIT on ARMv7.

* gnu/packages/make-bootstrap.scm (make-guile-static): Pass
"--disable-jit" when 'target-arm32?' is true.
---
 gnu/packages/make-bootstrap.scm | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/make-bootstrap.scm b/gnu/packages/make-bootstrap.scm
index fe86f810bf..b2d3e2a326 100644
--- a/gnu/packages/make-bootstrap.scm
+++ b/gnu/packages/make-bootstrap.scm
@@ -706,7 +706,12 @@ for `sh' in $PATH, and without nscd, and with static NSS 
modules."
           ;; When `configure' checks for ltdl availability, it
           ;; doesn't try to link using libtool, and thus fails
           ;; because of a missing -ldl.  Work around that.
-          ''("LDFLAGS=-ldl"))
+
+          ;; XXX: On ARMv7, disable JIT: it causes crashes with 3.0.2,
+          ;; possibly related to <https://bugs.gnu.org/40737>.
+          (if (target-arm32?)
+              ''("LDFLAGS=-ldl" "--disable-jit")
+              ''("LDFLAGS=-ldl")))
          ((#:phases phases '%standard-phases)
           `(modify-phases ,phases
 
-- 
2.26.2