09/23: bootloader: grub: Add support for multiboot.

[guix-commits]

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

commit 5528587cc5af40a1372baf30f0503086930b806f
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 | 71 ++++++++++++++++++++++++++++++-------------------
 2 files changed, 46 insertions(+), 28 deletions(-)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 2eebb8e..d0bcab1 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 2d9a39a..3e95fec 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,36 +334,49 @@ when booting a root file system on a Btrfs subvolume."
   (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
-                                   store-directory-prefix))
-           (initrd (normalize-file (menu-entry-initrd entry)
-                                   device-mount-point
-                                   store-directory-prefix)))
-      ;; 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.
-      #~(format port "menuentry ~s {
+    (match entry
+      (($ <menu-entry> label device mount-point linux arguments initrd #f ())
+       (let ((linux (normalize-file linux mount-point
+                                    store-directory-prefix))
+             (initrd (normalize-file initrd mount-point
+                                     store-directory-prefix)))
+         ;; 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))
-               #:store-directory-prefix store-directory-prefix
-               #: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 arguments 
modules)
+       (let* ((target (%current-target-system)))
+         #~(format port "
+menuentry ~s {
+  multiboot ~a root=device:hd0s1~a~a
+}~%"
+                   #$label
+                   #$kernel (string-join (list #$@arguments) " " 'prefix)
+                   (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
+                 #:store-directory-prefix store-directory-prefix
+                 #:system system
+                 #:port #~port)))
 
   (define keyboard-layout-config
     (let* ((layout (bootloader-configuration-keyboard-layout config))
@@ -384,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