nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

linux-initrd: Use 'call-with-error-handling' when booting. 

* guix/build/linux-initrd.scm (canonicalize-device-spec): When label
  resolution fails, call 'error' instead of 'format' + 'start-repl'.
  (boot-system): Wrap most of body in 'call-with-error-handling'.
  Remove 'catch' around 'primitive-load' call.
master
Ludovic Courtès 2014-07-03 22:44:14 +02:00
parent dccab4df20
commit e3ced65af0
1 changed files with 65 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
guix/build/linux-initrd.scm
View File

@ -20,6 +20,7 @@
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (system foreign) #:use-module (system foreign)
#:use-module (system repl error-handling)
#:autoload (system repl repl) (start-repl) #:autoload (system repl repl) (start-repl)
#:autoload (system base compile) (compile-file) #:autoload (system base compile) (compile-file)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -250,10 +251,7 @@ the following:
;; Some devices take a bit of time to appear, most notably USB ;; Some devices take a bit of time to appear, most notably USB
;; storage devices. Thus, wait for the device to appear. ;; storage devices. Thus, wait for the device to appear.
(if (> count max-trials) (if (> count max-trials)
(begin (error "failed to resolve partition label" spec)
(format (current-error-port)
"failed to resolve partition label: ~s~%" spec)
(start-repl))
(begin (begin
(sleep 1) (sleep 1)
(loop (+ 1 count)))))))) (loop (+ 1 count))))))))
@ -615,84 +613,79 @@ to it are lost."
(display "Welcome, this is GNU's early boot Guile.\n") (display "Welcome, this is GNU's early boot Guile.\n")
(display "Use '--repl' for an initrd REPL.\n\n") (display "Use '--repl' for an initrd REPL.\n\n")
(mount-essential-file-systems) (call-with-error-handling
(let* ((args (linux-command-line)) (lambda ()
(to-load (find-long-option "--load" args)) (mount-essential-file-systems)
(root (find-long-option "--root" args))) (let* ((args (linux-command-line))
(to-load (find-long-option "--load" args))
(root (find-long-option "--root" args)))
(when (member "--repl" args) (when (member "--repl" args)
(start-repl)) (start-repl))
(display "loading kernel modules...\n") (display "loading kernel modules...\n")
(for-each (compose load-linux-module* (for-each (compose load-linux-module*
(cut string-append "/modules/" <>)) (cut string-append "/modules/" <>))
linux-modules) linux-modules)
(when qemu-guest-networking? (when qemu-guest-networking?
(unless (configure-qemu-networking) (unless (configure-qemu-networking)
(display "network interface is DOWN\n"))) (display "network interface is DOWN\n")))
;; Make /dev nodes. ;; Make /dev nodes.
(make-essential-device-nodes) (make-essential-device-nodes)
;; Prepare the real root file system under /root. ;; Prepare the real root file system under /root.
(unless (file-exists? "/root") (unless (file-exists? "/root")
(mkdir "/root")) (mkdir "/root"))
(if root (if root
(mount-root-file-system (canonicalize-device-spec root) (mount-root-file-system (canonicalize-device-spec root)
root-fs-type root-fs-type
#:volatile-root? volatile-root?) #:volatile-root? volatile-root?)
(mount "none" "/root" "tmpfs")) (mount "none" "/root" "tmpfs"))
(unless (file-exists? "/root/dev") (unless (file-exists? "/root/dev")
(mkdir "/root/dev") (mkdir "/root/dev")
(make-essential-device-nodes #:root "/root")) (make-essential-device-nodes #:root "/root"))
;; Mount the specified file systems. ;; Mount the specified file systems.
(for-each mount-file-system (for-each mount-file-system
(remove root-mount-point? mounts)) (remove root-mount-point? mounts))
(when guile-modules-in-chroot? (when guile-modules-in-chroot?
;; Copy the directories that contain .scm and .go files so that the ;; Copy the directories that contain .scm and .go files so that the
;; child process in the chroot can load modules (we would bind-mount ;; child process in the chroot can load modules (we would bind-mount
;; them but for some reason that fails with EINVAL -- XXX). ;; them but for some reason that fails with EINVAL -- XXX).
(mkdir-p "/root/share") (mkdir-p "/root/share")
(mkdir-p "/root/lib") (mkdir-p "/root/lib")
(mount "none" "/root/share" "tmpfs") (mount "none" "/root/share" "tmpfs")
(mount "none" "/root/lib" "tmpfs") (mount "none" "/root/lib" "tmpfs")
(copy-recursively "/share" "/root/share" (copy-recursively "/share" "/root/share"
#:log (%make-void-port "w")) #:log (%make-void-port "w"))
(copy-recursively "/lib" "/root/lib" (copy-recursively "/lib" "/root/lib"
#:log (%make-void-port "w"))) #:log (%make-void-port "w")))
(if to-load (if to-load
(begin (begin
(switch-root "/root") (switch-root "/root")
(format #t "loading '~a'...\n" to-load) (format #t "loading '~a'...\n" to-load)
;; Obviously this has to be done each time we boot. Do it from here ;; Obviously this has to be done each time we boot. Do it from here
;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3)
;; expects (and thus openpty(3) and its users, such as xterm.) ;; expects (and thus openpty(3) and its users, such as xterm.)
(mount "none" "/dev/pts" "devpts") (mount "none" "/dev/pts" "devpts")
;; TODO: Remove /lib, /share, and /loader.go. ;; TODO: Remove /lib, /share, and /loader.go.
(catch #t (primitive-load to-load)
(lambda ()
(primitive-load to-load)) (format (current-error-port)
(lambda args "boot program '~a' terminated, rebooting~%"
(start-repl)) to-load)
(lambda args (sleep 2)
(format (current-error-port) "'~a' raised an exception: ~s~%" (reboot))
to-load args) (begin
(display-backtrace (make-stack #t) (current-error-port)))) (display "no boot file passed via '--load'\n")
(format (current-error-port) (display "entering a warm and cozy REPL\n")
"boot program '~a' terminated, rebooting~%" (start-repl)))))))
to-load)
(sleep 2)
(reboot))
(begin
(display "no boot file passed via '--load'\n")
(display "entering a warm and cozy REPL\n")
(start-repl)))))
;;; linux-initrd.scm ends here ;;; linux-initrd.scm ends here