[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[RFCv4] install: Create a GC root during install-grub.
From: |
Jookia |
Subject: |
[RFCv4] install: Create a GC root during install-grub. |
Date: |
Fri, 11 Mar 2016 17:35:26 +1100 |
While previously creating a GC root for GRUB's resources was the caller's
responsibility, it's much less repetitive to put it in install-grub now that
it's wrapped by error handling. This also means we can replace the install-grub*
function with a small definition inside perform-action named 'install-boot'.
* gnu/build/install.scm (install-grub): Make a GC root for grub.cfg on success.
(register-grub.cfg-root): Remove function, install-grub does this now.
* gnu/system/vm.scm (qemu-image): Don't explicitly make a GC root.
* guix/scripts/system.scm (install-grub*): Move useful parts to perform-action.
(perform-action): Use inline definition install-boot to install GRUB.
---
gnu/build/install.scm | 22 +++++++++-------------
gnu/system/vm.scm | 15 +++++++--------
guix/scripts/system.scm | 48 +++++++++++++-----------------------------------
3 files changed, 29 insertions(+), 56 deletions(-)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index e4f087f..b28dea8 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -22,7 +22,6 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (install-grub
- register-grub.cfg-root
populate-root-file-system
reset-timestamps
register-closure
@@ -39,13 +38,10 @@
(define* (install-grub grub.cfg device mount-point)
"Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
-MOUNT-POINT.
-
-Note that the caller must make sure that GRUB.CFG is registered as a GC root
-so that the fonts, background images, etc. referred to by GRUB.CFG are not
-GC'd."
+MOUNT-POINT."
(let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
- (pivot (string-append target ".new")))
+ (pivot (string-append target ".new"))
+ (gcroot "/var/guix/gcroots"))
(mkdir-p (dirname target))
;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't
@@ -57,13 +53,13 @@ GC'd."
"--boot-directory"
(string-append mount-point "/boot")
device))
- (error "failed to install GRUB"))))
+ (error "failed to install GRUB"))
-(define (register-grub.cfg-root target grub.cfg)
- "On file system TARGET, register GRUB.CFG as a GC root."
- (let ((directory (string-append target "/var/guix/gcroots")))
- (mkdir-p directory)
- (symlink grub.cfg (string-append directory "/grub.cfg"))))
+ ;; Register GRUB.CFG as a GC root so the fonts, background images, etc.
+ ;; referred to by GRUB.CFG are not GC'd.
+ (evaluate-populate-directive `(directory ,gcroot) mount-point)
+ (evaluate-populate-directive
+ `(,(string-append gcroot "/grub.cfg") -> ,grub.cfg) mount-point)))
(define (evaluate-populate-directive directive target)
"Evaluate DIRECTIVE, an sexp describing a file or directory to create under
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 35c573d..e8a577c 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -228,14 +228,13 @@ the image."
(guix build utils))
(define* (do-install-grub #:key device target)
- (and #$(prepare-install-grub
- #:mount-point 'target
- #:grub.cfg grub.cfg
- #:config
- (grub-configuration
- (inherit (operating-system-bootloader
os-configuration))
- (device drive)))
- (register-grub.cfg-root target #$grub.cfg)))
+ #$(prepare-install-grub
+ #:mount-point 'target
+ #:grub.cfg grub.cfg
+ #:config
+ (grub-configuration
+ (inherit (operating-system-bootloader os-configuration))
+ (device drive))))
(let ((inputs
'#$(append (list qemu parted grub e2fsprogs)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index dae47a5..bd92ae8 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -126,33 +126,6 @@ TARGET, and register them."
(map (cut copy-item <> target #:log-port log-port)
to-copy))))
-(define* (install-grub* #:key grub.cfg config target)
- "This is a variant of 'install-grub' with error handling, lifted in
-%STORE-MONAD"
- (let* ((gc-root (string-append target %gc-roots-directory
- "/grub.cfg"))
- (temp-gc-root (string-append gc-root ".new"))
- (delete-file (lift1 delete-file %store-monad))
- (make-symlink (lift2 switch-symlinks %store-monad))
- (rename (lift2 rename-file %store-monad)))
- (mbegin %store-monad
- ;; Prepare the symlink to GRUB.CFG to make sure that it's a GC root when
- ;; 'install-grub' completes (being a bit paranoid.)
- (make-symlink temp-gc-root grub.cfg)
-
- (munless (eval (prepare-install-grub
- #:grub.cfg grub.cfg
- #:config config
- #:mount-point target)
- (current-module))
- (delete-file temp-gc-root)
- (leave (_ "failed to install GRUB on device '~a'~%")
- (grub-configuration-device config)))
-
- ;; Register GRUB.CFG as a GC root so that its dependencies (background
- ;; image, font, etc.) are not reclaimed.
- (rename temp-gc-root gc-root))))
-
(define* (install os-drv target grub.cfg
#:key (log-port (current-output-port)))
"Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to
@@ -510,6 +483,7 @@ building anything."
(if (eq? 'init action)
'()
(previous-grub-entries)))))
+ (grub-config -> (operating-system-bootloader os))
;; For 'init' and 'reconfigure', always build GRUB.CFG, even if
;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
@@ -525,6 +499,16 @@ building anything."
(maybe-build drvs #:dry-run? dry-run?
#:use-substitutes? use-substitutes?))))
+ (define (install-boot mount-point)
+ (mbegin %store-monad
+ (munless (eval (prepare-install-grub
+ #:grub.cfg (derivation->output-path grub.cfg)
+ #:config grub-config
+ #:mount-point mount-point)
+ (current-module))
+ (leave (_ "failed to install GRUB on device '~a'~%")
+ (grub-configuration-device grub-config)))))
+
(if (or dry-run? derivations-only?)
(return #f)
(begin
@@ -543,10 +527,7 @@ building anything."
(mbegin %store-monad
(switch-to-system os)
(mwhen grub?
- (install-grub*
- #:grub.cfg (derivation->output-path grub.cfg)
- #:config (operating-system-bootloader os)
- #:target "/"))))
+ (install-boot "/"))))
((init)
(newline)
(format #t (_ "initializing operating system under '~a'...~%")
@@ -555,10 +536,7 @@ building anything."
(install sys (canonicalize-path target)
(derivation->output-path grub.cfg))
(mwhen grub?
- (install-grub*
- #:grub.cfg (derivation->output-path grub.cfg)
- #:config (operating-system-bootloader os)
- #:target target))))
+ (install-boot target))))
(else
;; All we had to do was to build SYS.
(return (derivation->output-path sys))))))))
--
2.7.0