Subject: Re: [PATCH v3] Allow booting from a Btrfs subvolume

From: Maxim Cournoyer <[email-masked]>
Date: Sun, 17 May 2020 12:13:34 -0400

Hi Pierre!

Pierre Neidhardt <[email-masked]> writes:

> I'll try to test this patch, possibly today.
>
> Is the patch from the 18th of March the right one?
> The patch says it has 5 components but the last patch is
>
> [PATCH 4/5] bootloader: grub: Allow booting from a Btrfs subvolume.
>
> Is the fifth patch missing?

As I send my patches as attachments rather than with git send-email, I
simply forgot to update the subject line counter.  There are four
patches in total, although the hack in 0001 was controversial so is
included as a curiosity only. I've rebased the 4 patches on current
master, and fixed some conflict that arose in the initrd code.

>From b72da2bbc450303ffa804b840b5cbbb6efd28b2f Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Sun, 17 Nov 2019 06:01:00 +0900
Subject: [PATCH 1/4] gnu: tests: Reduce the time required to run the system
 tests.

When setting the GUIX_DEV_HACKS environment variable, the Guix package used
inside the instrumented VMs recycles the binaries already found in the Guix
checkout of the developer instead of rebuilding Guix from scratch.  This
brings the time required for this component from 20+ minutes down to 2-3
minutes on an X200 machine.

* gnu/packages/package-management.scm (current-guix/pre-built): New procedure.
* etc/system-tests.scm (tests-for-channel-instance): Use it, when
GUIX_DEV_HACKS is defined.
---
 etc/system-tests.scm                |  5 ++-
 gnu/packages/package-management.scm | 66 +++++++++++++++++++++++++++++
 2 files changed, 70 insertions(+), 1 deletion(-)

diff --git a/etc/system-tests.scm b/etc/system-tests.scm
index 1085deed24..3bf684e584 100644
--- a/etc/system-tests.scm
+++ b/etc/system-tests.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2020 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -49,7 +50,9 @@ instance."
   ;;
   ;;   make check-system TESTS=installed-os
   (parameterize ((current-guix-package
-                  (channel-source->package source #:commit commit)))
+                  (if (getenv "GUIX_DEV_HACKS")
+                      (current-guix/pre-built)
+                      (channel-source->package source #:commit commit))))
     (match (getenv "TESTS")
       (#f
        (all-system-tests))
diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm
index 3fc6fc404a..4a6f37ba11 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -534,6 +534,72 @@ out) and returning a package that uses that as its 'source'."
                                 #:recursive? #t
                                 #:select? (force select?))))))))
 
+(define-public (current-guix/pre-built)
+  "Similar to `current-guix', but with a modified build procedure that
+reuses the existing byte compiled artifacts to save recompilation time."
+
+  (let* ( ;; The `current-source-directory' macro doesn't work from the REPL.
+         ;; For testing, you can replace it with a static string pointing to
+         ;; your Guix checkout directory.
+         (repository-root (delay (canonicalize-path
+                                  (string-append (current-source-directory)
+                                                 "/../.."))))
+         (select? (lambda (file stat)
+                    (match (basename file)
+                      ((or ".git"
+                           "configure" "autom4te.cache"
+                           "config.log" "config.status"
+                           "stamp-1" "stamp-2" "stamp-3" "stamp-4" "stamp-5"
+                           "stamp-h1" "stamp-vti"
+                           "Makefile" "Makefile.in" ".libs"
+                           ".deps" ".dirstamp"
+                           "test-tmp"
+                           ) #f)
+                      (_ #t)))))
+    (package
+      (inherit guix)
+      (version (string-append (package-version guix) "+"))
+      (source (local-file (force repository-root) "guix-current"
+                          #:recursive? #t
+                          #:select? select?))
+      (arguments
+       (substitute-keyword-arguments (package-arguments guix)
+         ((#:phases phases)
+          `(modify-phases ,phases
+             ;; XXX: References to tools such as 'mkdir' and 'install' are
+             ;; captured in Makefile.in when 'autoconf' is run.  It'd be nicer
+             ;; to find those at configuration time.
+             (delete 'copy-bootstrap-guile)
+             (delete 'check)
+             (delete 'disable-failing-tests)
+             (delete 'strip)            ;can't strip .go files anyway
+             (replace 'build
+               (lambda _
+                 ;; Set the write permission bit on some files that need to be
+                 ;; touched.
+                 (chmod "nix" #o777)
+                 (for-each (lambda (f)
+                             (chmod f #o666))
+                           (cons* "guix-daemon"
+                                  (find-files "." ".*\\.(a|o)$")))
+
+                 ;; The following prevent 'make install' from rebuilding the
+                 ;; daemon and the documentation.
+                 (invoke "make" "--touch" "info"
+                         ;; TODO: Currently we must rebuild the daemon as it
+                         ;; was linked against external dependencies that
+                         ;; depend on the provenance of the profile (or
+                         ;; environment) that was used to build it.
+
+                         ;; If we could query the provenance of any profile,
+                         ;; we could make this package inherit from the guix
+                         ;; inferior that was used to provide such
+                         ;; dependencies.  The most reliable way would
+                         ;; probably be to record that provenance at build
+                         ;; time (as a make target).
+                         ;"guix-daemon"
+                         ))))))))))
+
 
 ;;;
 ;;; Other tools.
-- 
2.26.2

>From b03a574ad565b34bbe8a7d3d0322591850984dc6 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Tue, 11 Feb 2020 14:00:06 -0500
Subject: [PATCH 2/4] linux-boot: Refactor boot-system.

The --root option can now be omitted, and inferred from the root file system
declaration instead.

* gnu/build/file-systems.scm (canonicalize-device-spec): Extend to support NFS
directly, and...
* gnu/build/linux-boot.scm (boot-system): ...remove NFS special casing from
here.  Remove nested definitions for root-fs-type, root-fs-flags and
root-fs-options, and bind those inside the let* instead.  Make "--root" take
precedence over the device field string representation of the root file
system.
* doc/guix.texi (Initial RAM Disk): Document that "--root" can be left
unspecified.
---
 doc/guix.texi              |  7 +++--
 gnu/build/file-systems.scm |  6 ++--
 gnu/build/linux-boot.scm   | 63 +++++++++++++++++---------------------
 3 files changed, 36 insertions(+), 40 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 22bf6bd224..3d8ea4b6c4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -26530,9 +26530,10 @@ service activation programs and then spawns the GNU@tie{}Shepherd, the
 initialization system.
 
 @item --root=@var{root}
-Mount @var{root} as the root file system.  @var{root} can be a
-device name like @code{/dev/sda1}, a file system label, or a file system
-UUID.
+Mount @var{root} as the root file system.  @var{root} can be a device
+name like @code{/dev/sda1}, a file system label, or a file system UUID.
+When unspecified, the device name from the root file system of the
+operating system declaration is used.
 
 @item --system=@var{system}
 Have @file{/run/booted-system} and @file{/run/current-system} point to
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index b920e8fc62..ad92d8a496 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -661,8 +661,10 @@ were found."
 
   (match spec
     ((? string?)
-     ;; Nothing to do, but wait until SPEC shows up.
-     (resolve identity spec identity))
+     (if (string-contains spec ":/")
+         spec                  ; do not resolve NFS devices
+         ;; Nothing to do, but wait until SPEC shows up.
+         (resolve identity spec identity)))
     ((? file-system-label?)
      ;; Resolve the label.
      (resolve find-partition-by-label
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index c6f9df5f29..f08bb11514 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -498,25 +498,13 @@ upon error."
   (define (root-mount-point? fs)
     (string=? (file-system-mount-point fs) "/"))
 
-  (define root-fs-type
-    (or (any (lambda (fs)
-               (and (root-mount-point? fs)
-                    (file-system-type fs)))
-             mounts)
-        "ext4"))
-
-  (define root-fs-flags
-    (mount-flags->bit-mask (or (any (lambda (fs)
-                                      (and (root-mount-point? fs)
-                                           (file-system-flags fs)))
-                                    mounts)
-                               '())))
-
-  (define root-fs-options
-    (any (lambda (fs)
-           (and (root-mount-point? fs)
-                (file-system-options fs)))
-         mounts))
+  (define (device-string->file-system-device device-string)
+    ;; The "--root=SPEC" kernel command-line option always provides a
+    ;; string, but the string can represent a device, a UUID, or a
+    ;; label.  So check for all three.
+    (cond ((string-prefix? "/" device-string) device-string)
+          ((uuid device-string) => identity)
+          (else (file-system-label device-string))))
 
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
@@ -526,7 +514,21 @@ upon error."
       (mount-essential-file-systems)
       (let* ((args    (linux-command-line))
              (to-load (find-long-option "--load" args))
-             (root    (find-long-option "--root" args)))
+             (root-fs (find root-mount-point? mounts))
+             (root-fs-type (or (and=> root-fs file-system-type)
+                               "ext4"))
+             (root-fs-device (and=> root-fs file-system-device))
+             (root-fs-flags (mount-flags->bit-mask
+                             (or (and=> root-fs file-system-flags)
+                                 '())))
+             (root-options (if root-fs
+                               (file-system-options root-fs)
+                               #f))
+             ;; --root takes precedence over the 'device' field of the root
+             ;; <file-system> record.
+             (root-device (or (and=> (find-long-option "--root" args)
+                                     device-string->file-system-device)
+                              root-fs-device)))
 
         (when (member "--repl" args)
           (start-repl))
@@ -561,21 +563,12 @@ upon error."
 
         (setenv "EXT2FS_NO_MTAB_OK" "1")
 
-        (if root
-            ;; The "--root=SPEC" kernel command-line option always provides a
-            ;; string, but the string can represent a device, a UUID, or a
-            ;; label.  So check for all three.
-            (let ((device-spec (cond ((string-prefix? "/" root) root)
-                                     ((uuid root) => identity)
-                                     ((string-contains root ":/") #f) ; nfs
-                                     (else (file-system-label root)))))
-              (mount-root-file-system (if device-spec
-                                          (canonicalize-device-spec device-spec)
-                                          root)
-                                      root-fs-type
-                                      #:volatile-root? volatile-root?
-                                      #:flags root-fs-flags
-                                      #:options root-fs-options))
+        (if root-device
+            (mount-root-file-system (canonicalize-device-spec root-device)
+                                    root-fs-type
+                                    #:volatile-root? volatile-root?
+                                    #:flags root-fs-flags
+                                    #:options root-options)
             (mount "none" "/root" "tmpfs"))
 
         ;; Mount the specified file systems.
-- 
2.26.2

>From 70737eac4ee6efebdb9c173e8ffe9ec710b9bc34 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Wed, 25 Sep 2019 22:43:41 +0900
Subject: [PATCH 3/4] file-systems: Add helpers for parsing the options string
 into an alist.

* gnu/system/file-systems.scm (file-system-options->alist)
(alist->file-system-options): New procedures.
* tests/file-systems.scm: New tests.
* doc/guix.texi (File Systems): Add note about the newly added procedures.
---
 doc/guix.texi               | 12 ++++++++----
 gnu/system/file-systems.scm | 31 +++++++++++++++++++++++++++++++
 tests/file-systems.scm      | 19 +++++++++++++++++++
 3 files changed, 58 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3d8ea4b6c4..6989a21bf9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11690,10 +11690,14 @@ update time on the in-memory version of the file inode), and
 Manual}, for more information on these flags.
 
 @item @code{options} (default: @code{#f})
-This is either @code{#f}, or a string denoting mount options passed to the
-file system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C Library
-Reference Manual}, for details and run @command{man 8 mount} for options for
-various file systems.
+This is either @code{#f}, or a string denoting mount options passed to
+the file system driver.  @xref{Mount-Unmount-Remount,,, libc, The GNU C
+Library Reference Manual}, for details and run @command{man 8 mount} for
+options for various file systems.  Note that the
+@code{file-system-options->alist} and @code{alist->file-system-options}
+procedures from @code{(gnu system file-systems)} can be used to convert
+file system options given as an association list to the string
+representation, and vice-versa.
 
 @item @code{mount?} (default: @code{#t})
 This value indicates whether to automatically mount the file system when
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index b41f66e943..07f272db7c 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2020 Jakub Kądziołka <[email-masked]>
+;;; Copyright © 2020 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,6 +39,9 @@
             file-system-needed-for-boot?
             file-system-flags
             file-system-options
+            file-system-options->alist
+            alist->file-system-options
+
             file-system-mount?
             file-system-check?
             file-system-create-mount-point?
@@ -251,6 +255,33 @@ UUID-TYPE, a symbol such as 'dce or 'iso9660."
     ((? string?)
      device)))
 
+(define (file-system-options->alist string)
+  "Translate the option string format of a <file-system> record into an
+association list of options or option/value pairs."
+  (if string
+      (let ((options (string-split string #\,)))
+        (map (lambda (param)
+               (let ((=index (string-index param #\=)))
+                 (if =index
+                     (cons (string-take param =index)
+                           (string-drop param (1+ =index)))
+                     param)))
+             options))
+      '()))
+
+(define (alist->file-system-options options)
+  "Return the string representation of OPTIONS, an association list.  The
+string obtained can be used as the option field of a <file-system> record."
+  (if (null? options)
+      #f
+      (string-join (map (match-lambda
+                          ((key . value)
+                           (string-append key "=" value))
+                          (key
+                           key))
+                        options)
+                   ",")))
+
 (define (file-system-needed-for-boot? fs)
   "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
 store--e.g., if FS is the root file system."
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 4c28d0ebc5..41f1021067 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2020 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -64,4 +65,22 @@
           (_ #f))
         (source-module-closure '((gnu system file-systems)))))
 
+(test-equal "file-system-options->alist"
+  '("autodefrag" ("subvol" . "home") ("compress" . "lzo"))
+  (file-system-options->alist "autodefrag,subvol=home,compress=lzo"))
+
+(test-equal "file-system-options->alist (#f)"
+  '()
+  (file-system-options->alist #f))
+
+(test-equal "alist->file-system-options"
+  "autodefrag,subvol=root,compress=lzo"
+  (alist->file-system-options '("autodefrag"
+                                ("subvol" . "root")
+                                ("compress" . "lzo"))))
+
+(test-equal "alist->file-system-options (null)"
+  #f
+  (alist->file-system-options '()))
+
 (test-end)
-- 
2.26.2

>From 082934db68964890ebd2a2118fb44d66911844d3 Mon Sep 17 00:00:00 2001
From: Maxim Cournoyer <[email-masked]>
Date: Sun, 14 Jul 2019 20:50:23 +0900
Subject: [PATCH 4/4] bootloader: grub: Allow booting from a Btrfs subvolume.

* gnu/bootloader/grub.scm (strip-mount-point): Remove procedure.
(normalize-file): Add procedure.
(grub-configuration-file): New BTRFS-SUBVOLUME-FILE-NAME parameter.  When
defined, prepend its value to the kernel and initrd file names, using the
NORMALIZE-FILE procedure.  Adjust the call to EYE-CANDY to pass the
BTRFS-SUBVOLUME-FILE-NAME argument.  Normalize the KEYMAP file as well.
(eye-candy): Add a BTRFS-SUBVOLUME-FILE-NAME parameter, and use it, along with
the NORMALIZE-FILE procedure, to normalize the FONT-FILE and IMAGE nested
variables.  Adjust doc.
* gnu/bootloader/depthcharge.scm (depthcharge-configuration-file): Adapt.
* gnu/bootloader/extlinux.scm (extlinux-configuration-file): Likewise.
* gnu/system/file-systems.scm (btrfs-subvolume?)
(btrfs-store-subvolume-file-name): New procedures.
* gnu/system.scm (operating-system-bootcfg): Specify the Btrfs
subvolume file name the store resides on to the
`operating-system-bootcfg' procedure, using the new
BTRFS-SUBVOLUME-FILE-NAME argument.
* doc/guix.texi (File Systems): Add a Btrfs subsection to document the use of
subvolumes.
* gnu/tests/install.scm: Add test "btrfs-root-on-subvolume-os".
---
 doc/guix.texi                  | 104 ++++++++++++++++++++++++++++
 gnu/bootloader/depthcharge.scm |   3 +-
 gnu/bootloader/extlinux.scm    |   3 +-
 gnu/bootloader/grub.scm        | 122 ++++++++++++++++++++-------------
 gnu/system.scm                 |   9 ++-
 gnu/system/file-systems.scm    |  58 ++++++++++++++++
 gnu/tests/install.scm          |  94 +++++++++++++++++++++++++
 tests/file-systems.scm         |  45 ++++++++++++
 8 files changed, 388 insertions(+), 50 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6989a21bf9..94f56559a9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11778,6 +11778,110 @@ and unmount user-space FUSE file systems.  This requires the
 @code{fuse.ko} kernel module to be loaded.
 @end defvr
 
+@node Btrfs file system
+@subsection Btrfs file system
+
+The Btrfs has special features, such as subvolumes, that merit being
+explained in more details.  The following section attempts to cover
+basic as well as complex uses of a Btrfs file system with the Guix
+System.
+
+In its simplest usage, a Btrfs file system can be described, for
+example, by:
+
+@lisp
+(file-system
+  (mount-point "/home")
+  (type "btrfs")
+  (device (file-system-label "my-home")))
+@end lisp
+
+The example below is more complex, as it makes use of a Btrfs
+subvolume, named @code{rootfs}.  The parent Btrfs file system is labeled
+@code{my-btrfs-pool}, and is located on an encrypted device (hence the
+dependency on @code{mapped-devices}):
+
+@lisp
+(file-system
+  (device (file-system-label "my-btrfs-pool"))
+  (mount-point "/")
+  (type "btrfs")
+  (options "subvol=rootfs")
+  (dependencies mapped-devices))
+@end lisp
+
+Some bootloaders, for example GRUB, only mount a Btrfs partition at its
+top level during the early boot, and rely on their configuration to
+refer to the correct subvolume path within that top level.  The
+bootloaders operating in this way typically produce their configuration
+on a running system where the Btrfs partitions are already mounted and
+where the subvolume information is readily available.  As an example,
+@command{grub-mkconfig}, the configuration generator command shipped
+with GRUB, reads @file{/proc/self/mountinfo} to determine the top-level
+path of a subvolume.
+
+The Guix System produces a bootloader configuration using the operating
+system configuration as its sole input; it is therefore necessary to
+extract the subvolume name on which @file{/gnu/store} lives (if any)
+from that operating system configuration.  To better illustrate,
+consider a subvolume named 'rootfs' which contains the root file system
+data.  In such situation, the GRUB bootloader would only see the top
+level of the root Btrfs partition, e.g.:
+
+@example
+/                   (top level)
+├── rootfs          (subvolume directory)
+    ├── gnu         (normal directory)
+        ├── store   (normal directory)
+[...]
+@end example
+
+Thus, the subvolume name must be prepended to the @file{/gnu/store} path
+of the kernel, initrd binaries and any other files referred to in the
+GRUB configuration that must be found during the early boot.
+
+The next example shows a nested hierarchy of subvolumes and
+directories:
+
+@example
+/                   (top level)
+├── rootfs          (subvolume)
+    ├── gnu         (normal directory)
+        ├── store   (subvolume)
+[...]
+@end example
+
+This scenario would work without mounting the 'store' subvolume.
+Mounting 'rootfs' is sufficient, since the subvolume name matches its
+intended mount point in the file system hierarchy.  Alternatively, the
+'store' subvolume could be referred to by setting the @code{subvol}
+option to either @code{/rootfs/gnu/store} or @code{rootfs/gnu/store}.
+
+Finally, a more contrived example of nested subvolumes:
+
+@example
+/                           (top level)
+├── root-snapshots          (subvolume)
+    ├── root-current        (subvolume)
+        ├── guix-store      (subvolume)
+[...]
+@end example
+
+Here, the 'guix-store' subvolume doesn't match its intended mount point,
+so it is necessary to mount it.  The subvolume must be fully specified,
+by passing its file name to the @code{subvol} option.  To illustrate,
+the 'guix-store' subvolume could be mounted on @file{/gnu/store} by using
+a file system declaration such as:
+
+@lisp
+(file-system
+  (device (file-system-label "btrfs-pool-1"))
+  (mount-point "/gnu/store")
+  (type "btrfs")
+  (options "subvol=root-snapshots/root-current/guix-store,\
+compress-force=zstd"))
+@end lisp
+
 @node Mapped Devices
 @section Mapped Devices
 
diff --git a/gnu/bootloader/depthcharge.scm b/gnu/bootloader/depthcharge.scm
index 58cc3f3932..0a50374bd9 100644
--- a/gnu/bootloader/depthcharge.scm
+++ b/gnu/bootloader/depthcharge.scm
@@ -82,7 +82,8 @@
 (define* (depthcharge-configuration-file config entries
                                          #:key
                                          (system (%current-system))
-                                         (old-entries '()))
+                                         (old-entries '())
+                                         #:allow-other-keys)
   (match entries
     ((entry)
      (let ((kernel (menu-entry-linux entry))
diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm
index 5b4dd84965..6b5ff298e7 100644
--- a/gnu/bootloader/extlinux.scm
+++ b/gnu/bootloader/extlinux.scm
@@ -28,7 +28,8 @@
 (define* (extlinux-configuration-file config entries
                                       #:key
                                       (system (%current-system))
-                                      (old-entries '()))
+                                      (old-entries '())
+                                      #:allow-other-keys)
   "Return the U-Boot configuration file corresponding to CONFIG, a
 <u-boot-configuration> object, and where the store is available at STORE-FS, a
 <file-system> object.  OLD-ENTRIES is taken to be a list of menu entries
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 8c5b5eac0c..e0218caba5 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -64,18 +64,29 @@
 ;;;
 ;;; Code:
 
-(define (strip-mount-point mount-point file)
-  "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
-denoting a file name."
-  (match mount-point
-    ((? string? mount-point)
-     (if (string=? mount-point "/")
-         file
-         #~(let ((file #$file))
-             (if (string-prefix? #$mount-point file)
-                 (substring #$file #$(string-length mount-point))
-                 file))))
-    (#f file)))
+(define* (normalize-file file mount-point btrfs-subvolume-file-name)
+  "Strip MOUNT-POINT and prepend BTRFS-SUBVOLUME-FILE-NAME to FILE, a
+G-expression or other lowerable object denoting a file name."
+
+  (define (strip-mount-point mount-point file)
+    (if mount-point
+        (if (string=? mount-point "/")
+            file
+            #~(let ((file #$file))
+                (if (string-prefix? #$mount-point file)
+                    (substring #$file #$(string-length mount-point))
+                    file)))
+        file))
+
+  (define (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name file)
+    (if btrfs-subvolume-file-name
+        #~(string-append #$btrfs-subvolume-file-name #$file)
+        file))
+
+  (prepend-btrfs-subvolume-file-name btrfs-subvolume-file-name
+                                     (strip-mount-point mount-point file)))
+
+
 
 (define-record-type* <grub-image>
   grub-image make-grub-image
@@ -143,13 +154,15 @@ WIDTH/HEIGHT, or #f if none was found."
                    #:width width #:height height))))
 
 (define* (eye-candy config store-device store-mount-point
+                    btrfs-store-subvolume-file-name
                     #:key system port)
-  "Return a gexp that writes to PORT (a port-valued gexp) the
-'grub.cfg' part concerned with graphics mode, background images, colors, and
-all that.  STORE-DEVICE designates the device holding the store, and
-STORE-MOUNT-POINT is its mount point; these are used to determine where the
-background image and fonts must be searched for.  SYSTEM must be the target
-system string---e.g., \"x86_64-linux\"."
+  "Return a gexp that writes to PORT (a port-valued gexp) the 'grub.cfg' part
+concerned with graphics mode, background images, colors, and all that.
+STORE-DEVICE designates the device holding the store, and STORE-MOUNT-POINT is
+its mount point; these are used to determine where the background image and
+fonts must be searched for.  SYSTEM must be the target system string---e.g.,
+\"x86_64-linux\".  BTRFS-STORE-SUBVOLUME-FILE-NAME is the file name of the
+Btrfs subvolume, to be prepended to any store path, if any."
   (define setup-gfxterm-body
     (let ((gfxmode
            (or (and-let* ((theme (bootloader-configuration-theme config))
@@ -186,11 +199,14 @@ fi~%" #+font-file)
                      (symbol->string (assoc-ref colors 'bg)))))
 
   (define font-file
-    (strip-mount-point store-mount-point
-                       (file-append grub "/share/grub/unicode.pf2")))
+    (normalize-file (file-append grub "/share/grub/unicode.pf2")
+                    store-mount-point
+                    btrfs-store-subvolume-file-name))
 
   (define image
-    (grub-background-image config))
+    (normalize-file (grub-background-image config)
+                    store-mount-point
+                    btrfs-store-subvolume-file-name))
 
   (and image
        #~(format #$port "
@@ -215,7 +231,7 @@ fi~%"
                  #$(setup-gfxterm config font-file)
                  #$(grub-setup-io config)
 
-                 #$(strip-mount-point store-mount-point image)
+                 #$image
                  #$(theme-colors grub-theme-color-normal)
                  #$(theme-colors grub-theme-color-highlight))))
 
@@ -323,52 +339,66 @@ code."
 (define* (grub-configuration-file config entries
                                   #:key
                                   (system (%current-system))
-                                  (old-entries '()))
+                                  (old-entries '())
+                                  btrfs-subvolume-file-name)
   "Return the GRUB configuration file corresponding to CONFIG, a
 <bootloader-configuration> object, and where the store is available at
-STORE-FS, a <file-system> object.  OLD-ENTRIES is taken to be a list of menu
-entries corresponding to old generations of the system."
+STORE-FS, a <file-system> object.  OLD-ENTRIES is taken to be a list
+of menu entries corresponding to old generations of the system.
+BTRFS-SUBVOLUME-FILE-NAME may be used to specify on which subvolume a
+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))
-          (kernel (menu-entry-linux entry))
-          (arguments (menu-entry-linux-arguments entry))
-          (initrd (menu-entry-initrd 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.
-      (let ((kernel  (strip-mount-point device-mount-point kernel))
-            (initrd  (strip-mount-point device-mount-point initrd)))
-        #~(format port "menuentry ~s {
+
+      ;; 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 {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
-                  #$label
-                  #$(grub-root-search device kernel)
-                  #$kernel (string-join (list #$@arguments))
-                  #$initrd))))
+                #$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-subvolume-file-name
                #:system system
                #:port #~port))
 
   (define keyboard-layout-config
-    (let ((layout (bootloader-configuration-keyboard-layout config))
-          (grub   (bootloader-package
-                   (bootloader-configuration-bootloader config))))
-      #~(let ((keymap #$(and layout
-                             (keyboard-layout-file layout #:grub grub))))
-          (when keymap
-            (format port "\
+    (let* ((layout (bootloader-configuration-keyboard-layout config))
+           (grub   (bootloader-package
+                    (bootloader-configuration-bootloader config)))
+           (keymap* (and layout
+                         (keyboard-layout-file layout #:grub grub)))
+           (keymap (and keymap*
+                        (if btrfs-subvolume-file-name
+                            #~(string-append #$btrfs-subvolume-file-name
+                                             #$keymap*)
+                            keymap*))))
+      #~(when #$keymap
+          (format port "\
 insmod keylayouts
-keymap ~a~%" keymap)))))
+keymap ~a~%" #$keymap))))
 
   (define builder
     #~(call-with-output-file #$output
diff --git a/gnu/system.scm b/gnu/system.scm
index cd75e4d4ba..d929187695 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 Danny Milosavljevic <[email-masked]>
 ;;; Copyright © 2020 Brice Waegeneire <[email-masked]>
 ;;; Copyright © 2020 Florian Pelz <[email-masked]>
+;;; Copyright © 2020 Maxim Cournoyer <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1102,19 +1103,23 @@ entry."
 (define* (operating-system-bootcfg os #:optional (old-entries '()))
   "Return the bootloader configuration file for OS.  Use OLD-ENTRIES,
 a list of <menu-entry>, to populate the \"old entries\" menu."
-  (let* ((root-fs         (operating-system-root-file-system os))
+  (let* ((file-systems    (operating-system-file-systems os))
+         (root-fs         (operating-system-root-file-system os))
          (root-device     (file-system-device root-fs))
          (params          (operating-system-boot-parameters
                            os root-device
                            #:system-kernel-arguments? #t))
          (entry           (boot-parameters->menu-entry params))
          (bootloader-conf (operating-system-bootloader os)))
+
     (define generate-config-file
       (bootloader-configuration-file-generator
        (bootloader-configuration-bootloader bootloader-conf)))
 
     (generate-config-file bootloader-conf (list entry)
-                          #:old-entries old-entries)))
+                          #:old-entries old-entries
+                          #:btrfs-subvolume-file-name
+			  (btrfs-store-subvolume-file-name file-systems))))
 
 (define* (operating-system-boot-parameters os root-device
                                            #:key system-kernel-arguments?)
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 07f272db7c..1f0c0cea4b 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -22,7 +22,10 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (guix records)
   #:use-module (gnu system uuid)
@@ -49,6 +52,8 @@
             file-system-location
 
             file-system-type-predicate
+            btrfs-subvolume?
+            btrfs-store-subvolume-file-name
 
             file-system-label
             file-system-label?
@@ -566,4 +571,57 @@ system has the given TYPE."
   (lambda (fs)
     (string=? (file-system-type fs) type)))
 
+
+;;;
+;;; Btrfs specific helpers.
+;;;
+
+(define (btrfs-subvolume? fs)
+  "Predicate to check if FS, a file-system object, is a Btrfs subvolume."
+  (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs)))
+             (option-keys (map (match-lambda
+                                 ((key . value) key)
+                                 (key key))
+                               (file-system-options->alist
+                                (file-system-options fs)))))
+    (find (cut string-prefix? "subvol" <>) option-keys)))
+
+(define (btrfs-store-subvolume-file-name file-systems)
+  "Return the subvolume file name within the Btrfs top level onto which the
+store is located, else #f."
+
+  (define (prepend-slash/maybe s)
+    (if (string=? "/" (string-take s 1))
+        s
+        (string-append "/" s)))
+
+  (define (file-name-depth file-name)
+    (length (string-tokenize file-name %not-slash)))
+
+  (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
+             (btrfs-subvolume-fs*
+              (sort btrfs-subvolume-fs
+                    (lambda (fs1 fs2)
+                      (> (file-name-depth (file-system-mount-point fs1))
+                         (file-name-depth (file-system-mount-point fs2))))))
+             (store-subvolume-fs
+              (find (lambda (fs) (file-prefix? (file-system-mount-point fs)
+                                               (%store-prefix)))
+                    btrfs-subvolume-fs*))
+             (options (file-system-options->alist
+                       (file-system-options store-subvolume-fs))))
+    ;; XXX: Deriving the subvolume name based from a subvolume ID is not
+    ;; supported, as we'd need to query the actual file system.
+    (or (and=> (assoc-ref options "subvol") prepend-slash/maybe)
+        ;; XXX: Importing (guix utils) and using &fix-hint causes the
+        ;; following error when booting the init RAM disk: "ERROR: In
+        ;; procedure dynamic-func:\nIn procedure dynamic-pointer: Symbol not
+        ;; found: strverscmp", so we just embed the hint in the message.
+        (raise (condition
+                (&message
+                 (message "The store is on a Btrfs subvolume, but the \
+subvolume name is unknown.
+Hint: Use the \"subvol\" Btrfs file system option.")))))))
+
+
 ;;; file-systems.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 94d970e1cc..cea26c8ef3 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -61,6 +61,7 @@
             %test-raid-root-os
             %test-encrypted-root-os
             %test-btrfs-root-os
+            %test-btrfs-root-on-subvolume-os
             %test-jfs-root-os
             %test-f2fs-root-os
 
@@ -863,6 +864,99 @@ build (current-guix) and then store a couple of full system images.")
                          (command (qemu-command/writable-image image)))
       (run-basic-test %btrfs-root-os command "btrfs-root-os")))))
 
+
+;;;
+;;; Btrfs root file system on a subvolume.
+;;;
+
+(define-os-with-source (%btrfs-root-on-subvolume-os
+                        %btrfs-root-on-subvolume-os-source)
+  ;; The OS we want to install.
+  (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+  (operating-system
+    (host-name "hurd")
+    (timezone "America/Montreal")
+    (locale "en_US.UTF-8")
+    (bootloader (bootloader-configuration
+                 (bootloader grub-bootloader)
+                 (target "/dev/vdb")))
+    (kernel-arguments '("console=ttyS0"))
+    (file-systems (cons* (file-system
+                           (device (file-system-label "btrfs-pool"))
+                           (mount-point "/")
+                           (options "subvol=rootfs,compress=zstd")
+                           (type "btrfs"))
+                         (file-system
+                           (device (file-system-label "btrfs-pool"))
+                           (mount-point "/home")
+                           (options "subvol=homefs,compress=lzo")
+                           (type "btrfs"))
+                         %base-file-systems))
+    (users (cons (user-account
+                  (name "charlie")
+                  (group "users")
+                  (supplementary-groups '("wheel" "audio" "video")))
+                 %base-user-accounts))
+    (services (cons (service marionette-service-type
+                             (marionette-configuration
+                              (imported-modules '((gnu services herd)
+                                                  (guix combinators)))))
+                    %base-services))))
+
+(define %btrfs-root-on-subvolume-installation-script
+  ;; Shell script of a simple installation.
+  "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+  mkpart primary ext2 1M 3M \\
+  mkpart primary ext2 3M 2G \\
+  set 1 boot on \\
+  set 1 bios_grub on
+
+# Setup the top level Btrfs file system with its subvolume.
+mkfs.btrfs -L btrfs-pool /dev/vdb2
+mount /dev/vdb2 /mnt
+btrfs subvolume create /mnt/rootfs
+btrfs subvolume create /mnt/homefs
+umount /dev/vdb2
+
+# Mount the subvolumes, ready for installation.
+mount LABEL=btrfs-pool -o 'subvol=rootfs,compress=zstd' /mnt
+mkdir /mnt/home
+mount LABEL=btrfs-pool -o 'subvol=homefs,compress=zstd' /mnt/home
+
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-btrfs-root-on-subvolume-os
+  (system-test
+   (name "btrfs-root-on-subvolume-os")
+   (description
+    "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+   (value
+    (mlet* %store-monad
+        ((image
+          (run-install %btrfs-root-on-subvolume-os
+                       %btrfs-root-on-subvolume-os-source
+                       #:script
+                       %btrfs-root-on-subvolume-installation-script))
+         (command (qemu-command/writable-image image)))
+      (run-basic-test %btrfs-root-on-subvolume-os command
+                      "btrfs-root-on-subvolume-os")))))
+
 
 ;;;
 ;;; JFS root file system.
diff --git a/tests/file-systems.scm b/tests/file-systems.scm
index 41f1021067..7f7c373884 100644
--- a/tests/file-systems.scm
+++ b/tests/file-systems.scm
@@ -83,4 +83,49 @@
   #f
   (alist->file-system-options '()))
 
+
+;;;
+;;; Btrfs related.
+;;;
+
+(define %btrfs-root-subvolume
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/")
+    (type "btrfs")
+    (options "subvol=rootfs,compress=zstd")))
+
+(define %btrfs-store-subvolid
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/gnu/store")
+    (type "btrfs")
+    (options "subvolid=10,compress=zstd")
+    (dependencies (list %btrfs-root-subvolume))))
+
+(define %btrfs-store-subvolume
+  (file-system
+    (device (file-system-label "btrfs-pool"))
+    (mount-point "/gnu/store")
+    (type "btrfs")
+    (options "subvol=/some/nested/file/name")
+    (dependencies (list %btrfs-root-subvolume))))
+
+(test-assert "btrfs-subvolume? (subvol)"
+  (btrfs-subvolume? %btrfs-root-subvolume))
+
+(test-assert "btrfs-subvolume? (subvolid)"
+  (btrfs-subvolume? %btrfs-store-subvolid))
+
+(test-equal "btrfs-store-subvolume-file-name"
+  "/some/nested/file/name"
+  (parameterize ((%store-prefix "/gnu/store"))
+    (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
+                                           %btrfs-store-subvolume))))
+
+(test-error "btrfs-store-subvolume-file-name (subvolid)"
+            (parameterize ((%store-prefix "/gnu/store"))
+              (btrfs-store-subvolume-file-name (list %btrfs-root-subvolume
+                                                     %btrfs-store-subvolid))))
+
 (test-end)
-- 
2.26.2

I'll test those rebased patches as well.  The automated system tests no
longer pass -- although it might not be specific to this change (I'll
try running the "installed-os" test to see if all the install tests are
broken or just this new "btrfs-root-on-subvolume-os" one.).  In case you
are not familiar with system tests, a single system test can be run
with:

make check-system TESTS="btrfs-root-on-subvolume-os"

The install tests are defined under (gnu tests install) and are *very*
expensive to run (mostly in time, but they require some disk space as
well).  Hence the hack in 0001, but I'm not sure if it brings as much
benefits as when I made it (given Ludovic keeps improving the way Guix
gets built :-)).

A fresh benchmark could be interesting if you have lots of time on your
hands.

Thank you for looking at this!

Maxim