24/35: bootloader: grub: Add support for multiboot.

[guix-commits]

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

commit 6f9352c3b9d1f19ae49a667692def7789f3f5448
Author: Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
AuthorDate: Tue May 26 18:09:01 2020 +0200

    bootloader: grub: Add support for multiboot.
    
    * gnu/bootloader/grub.scm (grub-configuration-file): Add support for
    multiboot.
---
 gnu/bootloader.scm      |  3 +-
 gnu/bootloader/grub.scm | 74 +++++++++++++++++++++++++++++--------------------
 2 files changed, 46 insertions(+), 31 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index a11e7df..c62aca9 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -26,7 +26,8 @@
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:export (menu-entry
+  #:export (<menu-entry>
+            menu-entry
             menu-entry?
             menu-entry-label
             menu-entry-device
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 388f29d..aa813e8 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -25,12 +25,16 @@
   #:use-module (guix records)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (guix gexp)
+  #:use-module (guix utils)
   #:use-module (gnu artwork)
   #:use-module (gnu bootloader)
   #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system keyboard)
+  #:use-module (gnu packages base)
   #:use-module (gnu packages bootloaders)
+  #:use-module (gnu packages cross-base)
+  #:use-module (gnu packages hurd)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
   #:autoload   (gnu packages xorg) (xkeyboard-config)
   #:use-module (ice-9 match)
@@ -330,39 +334,49 @@ Btrfs root file system resides."
   (define all-entries
     (append entries (bootloader-configuration-menu-entries config)))
   (define (menu-entry->gexp entry)
-    (let* ((device (menu-entry-device entry))
-           (device-mount-point (menu-entry-device-mount-point entry))
-           (label (menu-entry-label entry))
-           (arguments (menu-entry-linux-arguments entry))
-           (kernel (normalize-file (menu-entry-linux entry)
-                                   device-mount-point
-                                   btrfs-subvolume-file-name))
-           (initrd (normalize-file (menu-entry-initrd entry)
-                                   device-mount-point
-                                   btrfs-subvolume-file-name)))
-      ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-      ;; Use the right file names for KERNEL and INITRD in case
-      ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
-      ;; separate partition.
-
-      ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the kernel and
-      ;; initrd paths, to allow booting from a Btrfs subvolume.
-      #~(format port "menuentry ~s {
+    (match entry
+      (($ <menu-entry> label device mount-point linux arguments initrd #f ())
+       (let ((linux (normalize-file linux mount-point
+                                    btrfs-subvolume-file-name))
+             (initrd (normalize-file initrd mount-point
+                                     btrfs-subvolume-file-name)))
+         ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
+         ;; Use the right file names for LINUX and INITRD in case
+         ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+         ;; separate partition.
+
+         ;; When BTRFS-SUBVOLUME-FILE-NAME is defined, prepend it the linux and
+         ;; initrd paths, to allow booting from a Btrfs subvolume.
+         #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
-                #$label
-                #$(grub-root-search device kernel)
-                #$kernel (string-join (list #$@arguments))
-                #$initrd)))
-  (define sugar
-    (eye-candy config
-               (menu-entry-device (first all-entries))
-               (menu-entry-device-mount-point (first all-entries))
-               #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
-               #:system system
-               #:port #~port))
+                   #$label
+                   #$(grub-root-search device linux)
+                   #$linux (string-join (list #$@arguments))
+                   #$initrd)))
+      (($ <menu-entry> label device mount-point #f () #f kernel modules)
+       (let* ((target (%current-target-system)))
+         #~(format port "
+menuentry ~s {
+  multiboot ~a root=device:hd0s1~a
+}~%"
+                   #$label
+                   #$kernel
+                   (string-join (map string-join '#$modules)
+                                "\n  module " 'prefix))))))
+
+  (define (sugar)
+    (let* ((entry (first all-entries))
+           (device (menu-entry-device entry))
+           (mount-point (menu-entry-device-mount-point entry)))
+      (eye-candy config
+                 device
+                 mount-point
+                 #:btrfs-store-subvolume-file-name btrfs-subvolume-file-name
+                 #:system system
+                 #:port #~port)))
 
   (define keyboard-layout-config
     (let* ((layout (bootloader-configuration-keyboard-layout config))
@@ -387,7 +401,7 @@ keymap ~a~%" #$keymap))))
                   "# This file was generated from your Guix configuration.  
Any changes
 # will be lost upon reconfiguration.
 ")
-          #$sugar
+          #$(sugar)
           #$keyboard-layout-config
           (format port "
 set default=~a