15/27: system: Add 'multiboot-modules' field to <boot-parameters>.

[guix-commits]

janneke pushed a commit to branch wip-hurd-vm
in repository guix.

commit 1ed230e598cad52dd5051e46fec388fd74238bd6
Author: Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
AuthorDate: Tue May 26 17:38:30 2020 +0200

    system: Add 'multiboot-modules' field to <boot-parameters>.
    
    * gnu/system.scm (<boot-parameters>)[multiboot-modules]: New field.
    (read-boot-parameters): Initialize it.
    (operating-system-multiboot-modules, hurd-multiboot-modules): New procedure.
    (operating-system-boot-parameters): Cater for multiboot the Hurd and
    initialize it; avoid initrd in that case.
    (operating-system-kernel-file): Cater for for Gnumach (the Hurd) besides 
Linux.
    (boot-parameters->menu-entry): Use it to support a multiboot <menu-entry>.
---
 gnu/system.scm | 89 +++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 70 insertions(+), 19 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index c35947c..a14ca08 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -39,9 +39,11 @@
   #:use-module (guix utils)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
+  #:use-module (gnu packages cross-base)
   #:use-module (gnu packages guile)
   #:use-module (gnu packages guile-xyz)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages hurd)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages pciutils)
   #:use-module (gnu packages package-management)
@@ -142,6 +144,7 @@
             boot-parameters-kernel
             boot-parameters-kernel-arguments
             boot-parameters-initrd
+            boot-parameters-multiboot-modules
             read-boot-parameters
             read-boot-parameters-file
             boot-parameters->menu-entry
@@ -283,7 +286,8 @@ directly by the user."
   (store-mount-point boot-parameters-store-mount-point)
   (kernel           boot-parameters-kernel)
   (kernel-arguments boot-parameters-kernel-arguments)
-  (initrd           boot-parameters-initrd))
+  (initrd           boot-parameters-initrd)
+  (multiboot-modules boot-parameters-multiboot-modules))
 
 (define (ensure-not-/dev device)
   "If DEVICE starts with a slash, return #f.  This is meant to filter out
@@ -314,7 +318,7 @@ file system labels."
   (match (read port)
     (('boot-parameters ('version 0)
                        ('label label) ('root-device root)
-                       ('kernel linux)
+                       ('kernel kernel)
                        rest ...)
      (boot-parameters
       (label label)
@@ -330,12 +334,12 @@ file system labels."
          ((_ entries) (map sexp->menu-entry entries))
          (#f          '())))
 
-      ;; In the past, we would store the directory name of the kernel instead
-      ;; of the absolute file name of its image.  Detect that and correct it.
-      (kernel (if (string=? linux (direct-store-path linux))
-                  (string-append linux "/"
+      ;; In the past, we would store the directory name of linux instead of
+      ;; the absolute file name of its image.  Detect that and correct it.
+      (kernel (if (string=? kernel (direct-store-path kernel))
+                  (string-append kernel "/"
                                  (system-linux-image-file-name))
-                  linux))
+                  kernel))
 
       (kernel-arguments
        (match (assq 'kernel-arguments rest)
@@ -349,6 +353,8 @@ file system labels."
          (('initrd (? string? file))
           file)))
 
+      (multiboot-modules (or (assq 'multiboot-modules rest) '()))
+
       (store-device
        ;; Linux device names like "/dev/sda1" are not suitable GRUB device
        ;; identifiers, so we just filter them out.
@@ -386,14 +392,22 @@ The object has its kernel-arguments extended in order to 
make it bootable."
                                (boot-parameters-kernel-arguments params))))))
 
 (define (boot-parameters->menu-entry conf)
-  (menu-entry
-   (label (boot-parameters-label conf))
-   (device (boot-parameters-store-device conf))
-   (device-mount-point (boot-parameters-store-mount-point conf))
-   (linux (boot-parameters-kernel conf))
-   (linux-arguments (boot-parameters-kernel-arguments conf))
-   (initrd (boot-parameters-initrd conf))))
-
+  (let* ((kernel (boot-parameters-kernel conf))
+         (multiboot-modules (boot-parameters-multiboot-modules conf))
+         (multiboot? (pair? multiboot-modules)))
+    (menu-entry
+     (label (boot-parameters-label conf))
+     (device (boot-parameters-store-device conf))
+     (device-mount-point (boot-parameters-store-mount-point conf))
+     (linux (and (not multiboot?) kernel))
+     (linux-arguments (if (not multiboot?) '
+                          (boot-parameters-kernel-arguments conf)
+                          '()))
+     (initrd (boot-parameters-initrd conf))
+     (multiboot-kernel (and multiboot? kernel))
+     (multiboot-modules (if multiboot?
+                            (boot-parameters-multiboot-modules conf)
+                            '())))))
 
 
 ;;;
@@ -485,8 +499,17 @@ from the initrd."
 (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)))
+  (if (operating-system-hurd os)
+      (let* ((mach (operating-system-kernel os))
+             (mach (if (%current-target-system)
+                       ;; A cross-built GNUmach does not work
+                       (with-parameters ((%current-system "i686-linux")
+                                         (%current-target-system #f))
+                         mach)
+                       mach)))
+        (file-append mach "/boot/gnumach"))
+      (file-append (operating-system-kernel os)
+                      "/" (system-linux-image-file-name))))
 
 (define (package-for-kernel target-kernel module-package)
   "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if
@@ -1131,17 +1154,44 @@ a list of <menu-entry>, to populate the \"old entries\" 
menu."
                           #:btrfs-subvolume-file-name
                          (btrfs-store-subvolume-file-name file-systems))))
 
+(define (operating-system-multiboot-modules os)
+  (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
+
+(define (hurd-multiboot-modules os)
+  (let* ((hurd (operating-system-hurd os))
+         (root-file-system-command
+          (list (file-append hurd "/hurd/ext2fs.static")
+                "ext2fs"
+                "--multiboot-command-line='${kernel-command-line}'"
+                "--host-priv-port='${host-port}'"
+                "--device-master-port='${device-port}'"
+                "--exec-server-task='${exec-task}'"
+                "--store-type=typed"
+                "--x-xattr-translator-records"
+                "'${root}'" "'$(task-create)'" "'$(task-resume)'"))
+         (target (%current-target-system))
+         (libc (if target
+                   (with-parameters ((%current-target-system #f))
+                     (cross-libc target))
+                   glibc))
+         (exec-server-command
+          (list (file-append libc "/lib/ld.so.1") "exec"
+                (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")))
+    (list root-file-system-command exec-server-command)))
+
 (define* (operating-system-boot-parameters os root-device
                                            #:key system-kernel-arguments?)
   "Return a monadic <boot-parameters> record that describes the boot
 parameters of OS.  When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments
 such as '--root' and '--load' to <boot-parameters>."
-  (let* ((initrd          (operating-system-initrd-file os))
+  (let* ((initrd          (and (not (hurd-target?))
+                               (operating-system-initrd-file os)))
          (store           (operating-system-store-file-system os))
          (bootloader      (bootloader-configuration-bootloader
                            (operating-system-bootloader os)))
          (bootloader-name (bootloader-name bootloader))
-         (label           (operating-system-label os)))
+         (label           (operating-system-label os))
+         (multiboot-modules (operating-system-multiboot-modules os)))
     (boot-parameters
      (label label)
      (root-device root-device)
@@ -1151,6 +1201,7 @@ such as '--root' and '--load' to <boot-parameters>."
           (operating-system-kernel-arguments os root-device)
           (operating-system-user-kernel-arguments os)))
      (initrd initrd)
+     (multiboot-modules multiboot-modules)
      (bootloader-name bootloader-name)
      (bootloader-menu-entries
       (bootloader-configuration-menu-entries (operating-system-bootloader os)))