linux-boot.scm 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016, 2017, 2019–2021 Tobias Geerinckx-Rice <me@tobias.gr>
  4. ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
  5. ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
  6. ;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
  7. ;;;
  8. ;;; This file is part of GNU Guix.
  9. ;;;
  10. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11. ;;; under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 3 of the License, or (at
  13. ;;; your option) any later version.
  14. ;;;
  15. ;;; GNU Guix is distributed in the hope that it will be useful, but
  16. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;;; GNU General Public License for more details.
  19. ;;;
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  22. (define-module (gnu build linux-boot)
  23. #:use-module (rnrs io ports)
  24. #:use-module (system repl error-handling)
  25. #:autoload (system repl repl) (start-repl)
  26. #:use-module (srfi srfi-1)
  27. #:use-module (srfi srfi-9)
  28. #:use-module (srfi srfi-11)
  29. #:use-module (srfi srfi-26)
  30. #:use-module (ice-9 match)
  31. #:use-module (ice-9 rdelim)
  32. #:use-module (ice-9 regex)
  33. #:use-module (ice-9 ftw)
  34. #:use-module (guix build utils)
  35. #:use-module ((guix build syscalls)
  36. #:hide (file-system-type))
  37. #:use-module (gnu build linux-modules)
  38. #:use-module (gnu build file-systems)
  39. #:use-module (gnu system file-systems)
  40. #:export (mount-essential-file-systems
  41. linux-command-line
  42. find-long-option
  43. find-long-options
  44. make-essential-device-nodes
  45. make-static-device-nodes
  46. configure-qemu-networking
  47. boot-system))
  48. ;;; Commentary:
  49. ;;;
  50. ;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that
  51. ;;; many of these use procedures not yet available in vanilla Guile (`mount',
  52. ;;; `load-linux-module', etc.); these are provided by a Guile patch used in
  53. ;;; the GNU distribution.
  54. ;;;
  55. ;;; Code:
  56. (define* (mount-essential-file-systems #:key (root "/"))
  57. "Mount /dev, /proc, and /sys under ROOT."
  58. (define (scope dir)
  59. (string-append root
  60. (if (string-suffix? "/" root)
  61. ""
  62. "/")
  63. dir))
  64. (unless (file-exists? (scope "proc"))
  65. (mkdir (scope "proc")))
  66. (mount "none" (scope "proc") "proc")
  67. (unless (file-exists? (scope "dev"))
  68. (mkdir (scope "dev")))
  69. (mount "none" (scope "dev") "devtmpfs")
  70. (unless (file-exists? (scope "sys"))
  71. (mkdir (scope "sys")))
  72. (mount "none" (scope "sys") "sysfs"))
  73. (define (move-essential-file-systems root)
  74. "Move currently mounted essential file systems to ROOT."
  75. (for-each (lambda (dir)
  76. (let ((target (string-append root dir)))
  77. (unless (file-exists? target)
  78. (mkdir target))
  79. (mount dir target "" MS_MOVE)))
  80. '("/dev" "/proc" "/sys")))
  81. (define (linux-command-line)
  82. "Return the Linux kernel command line as a list of strings."
  83. (string-tokenize
  84. (call-with-input-file "/proc/cmdline"
  85. get-string-all)))
  86. (define (find-long-option option arguments)
  87. "Find OPTION among ARGUMENTS, where OPTION is something like \"gnu.load\".
  88. Return the value associated with OPTION, or #f on failure."
  89. (let ((opt (string-append option "=")))
  90. (and=> (find (cut string-prefix? opt <>)
  91. arguments)
  92. (lambda (arg)
  93. (substring arg (+ 1 (string-index arg #\=)))))))
  94. (define (find-long-options option arguments)
  95. "Find OPTIONs among ARGUMENTS, where OPTION is something like \"console\".
  96. Return the values associated with OPTIONs as a list, or the empty list if
  97. OPTION doesn't appear in ARGUMENTS."
  98. (let ((opt (string-append option "=")))
  99. (filter-map (lambda (arg)
  100. (and (string-prefix? opt arg)
  101. (substring arg (+ 1 (string-index arg #\=)))))
  102. arguments)))
  103. (define (resume-if-hibernated device)
  104. "Resume from hibernation if possible. This is safe ONLY if no on-disk file
  105. systems have been mounted; calling it later risks severe file system corruption!
  106. See <Documentation/swsusp.txt> in the kernel source directory. This is the
  107. caller's responsibility, as is catching exceptions if resumption was supposed to
  108. happen but didn't.
  109. Resume only from DEVICE if it's a string. If it's #f, use the kernel's default
  110. hibernation device (CONFIG_PM_STD_PARTITION). Never return if resumption
  111. succeeds. Return nothing otherwise. The kernel logs any details to dmesg."
  112. (define (string->major:minor string)
  113. "Return a string with MAJOR:MINOR numbers of the device specified by STRING"
  114. ;; The "resume=" kernel command-line option always provides a string, which
  115. ;; can represent a device, a UUID, or a label. Check for all three.
  116. (let* ((spec (cond ((string-prefix? "/" string) string)
  117. ((uuid string) => identity)
  118. (else (file-system-label string))))
  119. ;; XXX The kernel's swsusp_resume_can_resume() waits if ‘resumewait’
  120. ;; is found on the command line; our canonicalize-device-spec gives
  121. ;; up after 20 seconds. We could emulate the former by looping…
  122. (device (canonicalize-device-spec spec))
  123. (rdev (stat:rdev (stat device))))
  124. (let-values (((major minor) (device-number->major+minor rdev)))
  125. (format #f "~a:~a" major minor))))
  126. ;; Write the resume DEVICE to this magic file, using the MAJOR:MINOR device
  127. ;; numbers if possible. The kernel will immediately try to resume from it.
  128. (let ((resume "/sys/power/resume"))
  129. (when (file-exists? resume) ; this kernel supports hibernation
  130. ;; Honour the kernel's default device (only) if none other was given.
  131. (let ((major:minor (if device
  132. (or (false-if-exception (string->major:minor
  133. device))
  134. ;; We can't parse it. Maybe the kernel can.
  135. device)
  136. (let ((default (call-with-input-file resume
  137. read-line)))
  138. ;; Don't waste time echoing 0:0 to /sys.
  139. (if (string=? "0:0" default)
  140. #f
  141. default)))))
  142. (when major:minor
  143. (call-with-output-file resume ; may throw an ‘Invalid argument’
  144. (cut display major:minor <>))))))) ; may never return
  145. (define* (make-disk-device-nodes base major #:optional (minor 0))
  146. "Make the block device nodes around BASE (something like \"/root/dev/sda\")
  147. with the given MAJOR number, starting with MINOR."
  148. (mknod base 'block-special #o644 (device-number major minor))
  149. (let loop ((i 1))
  150. (when (< i 16)
  151. (mknod (string-append base (number->string i))
  152. 'block-special #o644 (device-number major (+ minor i)))
  153. (loop (+ i 1)))))
  154. ;; Representation of a /dev node.
  155. (define-record-type <device-node>
  156. (device-node name type major minor module)
  157. device-node?
  158. (name device-node-name)
  159. (type device-node-type)
  160. (major device-node-major)
  161. (minor device-node-minor)
  162. (module device-node-module))
  163. (define (read-static-device-nodes port)
  164. "Read from PORT a list of <device-node> written in the format used by
  165. /lib/modules/*/*.devname files."
  166. (let loop ((line (read-line port)))
  167. (if (eof-object? line)
  168. '()
  169. (match (string-split line #\space)
  170. (((? (cut string-prefix? "#" <>)) _ ...)
  171. (loop (read-line port)))
  172. ((module-name device-name device-spec)
  173. (let* ((device-parts
  174. (string-match "([bc])([0-9][0-9]*):([0-9][0-9]*)"
  175. device-spec))
  176. (type-string (match:substring device-parts 1))
  177. (type (match type-string
  178. ("c" 'char-special)
  179. ("b" 'block-special)))
  180. (major-string (match:substring device-parts 2))
  181. (major (string->number major-string 10))
  182. (minor-string (match:substring device-parts 3))
  183. (minor (string->number minor-string 10)))
  184. (cons (device-node device-name type major minor module-name)
  185. (loop (read-line port)))))
  186. (_
  187. (begin
  188. (format (current-error-port)
  189. "read-static-device-nodes: ignored devname line '~a'~%" line)
  190. (loop (read-line port))))))))
  191. (define* (mkdir-p* dir #:optional (mode #o755))
  192. "This is a variant of 'mkdir-p' that works around
  193. <http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
  194. (define absolute?
  195. (string-prefix? "/" dir))
  196. (define not-slash
  197. (char-set-complement (char-set #\/)))
  198. (let loop ((components (string-tokenize dir not-slash))
  199. (root (if absolute?
  200. ""
  201. ".")))
  202. (match components
  203. ((head tail ...)
  204. (let ((path (string-append root "/" head)))
  205. (catch 'system-error
  206. (lambda ()
  207. (mkdir path mode)
  208. (loop tail path))
  209. (lambda args
  210. (if (= EEXIST (system-error-errno args))
  211. (loop tail path)
  212. (apply throw args))))))
  213. (() #t))))
  214. (define (report-system-error name . args)
  215. "Report a system error for the file NAME."
  216. (let ((errno (system-error-errno args)))
  217. (format (current-error-port) "could not create '~a': ~a~%" name
  218. (strerror errno))))
  219. ;; Catch a system-error, log it and don't die from it.
  220. (define-syntax-rule (catch-system-error name exp)
  221. (catch 'system-error
  222. (lambda ()
  223. exp)
  224. (lambda args
  225. (apply report-system-error name args))))
  226. ;; Create a device node like the <device-node> passed here on the file system.
  227. (define create-device-node
  228. (match-lambda
  229. (($ <device-node> xname type major minor module)
  230. (let ((name (string-append "/dev/" xname)))
  231. (mkdir-p* (dirname name))
  232. (catch-system-error name
  233. (mknod name type #o600 (device-number major minor)))))))
  234. (define* (make-static-device-nodes linux-release-module-directory)
  235. "Create static device nodes required by the given Linux release.
  236. This is required in order to solve a chicken-or-egg problem:
  237. The Linux kernel has a feature to autoload modules when a device is first
  238. accessed.
  239. And udev has a feature to set the permissions of static nodes correctly
  240. when it is starting up and also to automatically create nodes when hardware
  241. is hotplugged. That leaves universal device files which are not linked to
  242. one specific hardware device. These we have to create."
  243. (let ((devname-name (string-append linux-release-module-directory "/"
  244. "modules.devname")))
  245. (for-each create-device-node
  246. (call-with-input-file devname-name
  247. read-static-device-nodes))))
  248. (define* (make-essential-device-nodes #:optional (root "/"))
  249. "Make essential device nodes under ROOT/dev."
  250. ;; The hand-made devtmpfs/udev!
  251. (define (scope dir)
  252. (string-append root
  253. (if (string-suffix? "/" root)
  254. ""
  255. "/")
  256. dir))
  257. (unless (file-exists? (scope "dev"))
  258. (mkdir (scope "dev")))
  259. ;; Make the device nodes for SCSI disks.
  260. (make-disk-device-nodes (scope "dev/sda") 8)
  261. (make-disk-device-nodes (scope "dev/sdb") 8 16)
  262. (make-disk-device-nodes (scope "dev/sdc") 8 32)
  263. (make-disk-device-nodes (scope "dev/sdd") 8 48)
  264. ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
  265. (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
  266. (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
  267. ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
  268. (make-disk-device-nodes (scope "dev/vda") 252)
  269. ;; Memory (used by Xorg's VESA driver.)
  270. (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
  271. (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
  272. ;; Inputs (used by Xorg.)
  273. (unless (file-exists? (scope "dev/input"))
  274. (mkdir (scope "dev/input")))
  275. (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
  276. (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
  277. (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
  278. ;; System console. This node is magically created by the kernel on the
  279. ;; initrd's root, so don't try to create it in that case.
  280. (unless (string=? root "/")
  281. (mknod (scope "dev/console") 'char-special #o600
  282. (device-number 5 1)))
  283. ;; TTYs.
  284. (mknod (scope "dev/tty") 'char-special #o600
  285. (device-number 5 0))
  286. (chmod (scope "dev/tty") #o666)
  287. (let loop ((n 0))
  288. (and (< n 50)
  289. (let ((name (format #f "dev/tty~a" n)))
  290. (mknod (scope name) 'char-special #o600
  291. (device-number 4 n))
  292. (loop (+ 1 n)))))
  293. ;; Serial line.
  294. (mknod (scope "dev/ttyS0") 'char-special #o660
  295. (device-number 4 64))
  296. ;; Pseudo ttys.
  297. (mknod (scope "dev/ptmx") 'char-special #o666
  298. (device-number 5 2))
  299. (chmod (scope "dev/ptmx") #o666)
  300. ;; Create /dev/pts; it will be mounted later, at boot time.
  301. (unless (file-exists? (scope "dev/pts"))
  302. (mkdir (scope "dev/pts")))
  303. ;; Rendez-vous point for syslogd.
  304. (mknod (scope "dev/log") 'socket #o666 0)
  305. (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
  306. ;; Other useful nodes, notably relied on by guix-daemon.
  307. (for-each (match-lambda
  308. ((file major minor)
  309. (mknod (scope file) 'char-special #o666
  310. (device-number major minor))
  311. (chmod (scope file) #o666)))
  312. '(("dev/null" 1 3)
  313. ("dev/zero" 1 5)
  314. ("dev/full" 1 7)
  315. ("dev/random" 1 8)
  316. ("dev/urandom" 1 9)))
  317. (symlink "/proc/self/fd" (scope "dev/fd"))
  318. (symlink "/proc/self/fd/0" (scope "dev/stdin"))
  319. (symlink "/proc/self/fd/1" (scope "dev/stdout"))
  320. (symlink "/proc/self/fd/2" (scope "dev/stderr"))
  321. ;; Loopback devices.
  322. (let loop ((i 0))
  323. (when (< i 8)
  324. (mknod (scope (string-append "dev/loop" (number->string i)))
  325. 'block-special #o660
  326. (device-number 7 i))
  327. (loop (+ 1 i))))
  328. ;; File systems in user space (FUSE).
  329. (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
  330. (define %host-qemu-ipv4-address
  331. (inet-pton AF_INET "10.0.2.10"))
  332. (define* (configure-qemu-networking #:optional (interface "eth0"))
  333. "Setup the INTERFACE network interface and /etc/resolv.conf according to
  334. QEMU's default networking settings (see net/slirp.c in QEMU for default
  335. networking values.) Return #t if INTERFACE is up, #f otherwise."
  336. (display "configuring QEMU networking...\n")
  337. (let* ((sock (socket AF_INET SOCK_STREAM 0))
  338. (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
  339. (flags (network-interface-flags sock interface)))
  340. (set-network-interface-address sock interface address)
  341. (set-network-interface-flags sock interface (logior flags IFF_UP))
  342. (logand (network-interface-flags sock interface) IFF_UP)))
  343. (define (pidof program)
  344. "Return the PID of the first presumed instance of PROGRAM."
  345. (let ((program (basename program)))
  346. (find (lambda (pid)
  347. (let ((exe (format #f "/proc/~a/exe" pid)))
  348. (and=> (false-if-exception (readlink exe))
  349. (compose (cut string=? program <>) basename))))
  350. (filter-map string->number (scandir "/proc")))))
  351. (define* (mount-root-file-system root type
  352. #:key volatile-root? (flags 0) options
  353. check? skip-check-if-clean? repair)
  354. "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is
  355. true, mount ROOT read-only and make it an overlay with a writable tmpfs using
  356. the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use
  357. to mount ROOT, and behave the same as for the `mount' procedure.
  358. If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively.
  359. If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is
  360. marked as clean. If REPAIR is true, fsck may write to ROOT to perform repairs.
  361. If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it
  362. considers safe."
  363. (if volatile-root?
  364. (begin
  365. (mkdir-p "/real-root")
  366. (mount root "/real-root" type (logior MS_RDONLY flags) options)
  367. (mkdir-p "/rw-root")
  368. (mount "none" "/rw-root" "tmpfs")
  369. ;; Create the upperdir and the workdir of the overlayfs
  370. (mkdir-p "/rw-root/upper")
  371. (mkdir-p "/rw-root/work")
  372. ;; We want read-write /dev nodes.
  373. (mkdir-p "/rw-root/upper/dev")
  374. (mount "none" "/rw-root/upper/dev" "devtmpfs")
  375. ;; Make /root an overlay of the tmpfs and the actual root.
  376. (mount "none" "/root" "overlay" 0
  377. "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
  378. (begin
  379. (when check?
  380. (check-file-system root type (not skip-check-if-clean?) repair))
  381. (mount root "/root" type flags options)))
  382. ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
  383. (false-if-exception
  384. (delete-file "/root/etc/mtab"))
  385. (mkdir-p "/root/etc")
  386. (symlink "/proc/self/mounts" "/root/etc/mtab"))
  387. (define (switch-root root)
  388. "Switch to ROOT as the root file system, in a way similar to what
  389. util-linux' switch_root(8) does."
  390. (move-essential-file-systems root)
  391. (chdir root)
  392. ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
  393. ;; TODO: Use 'statfs' to check the fs type, like klibc does.
  394. (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
  395. (format (current-error-port)
  396. "The root file system is probably not an initrd; \
  397. bailing out.~%root contents: ~s~%" (scandir "/"))
  398. (force-output (current-error-port))
  399. (exit 1))
  400. ;; Delete files from the old root, without crossing mount points (assuming
  401. ;; there are no mount points in sub-directories.) That means we're leaving
  402. ;; the empty ROOT directory behind us, but that's OK.
  403. (let ((root-device (stat:dev (stat "/"))))
  404. (for-each (lambda (file)
  405. (unless (member file '("." ".."))
  406. (let* ((file (string-append "/" file))
  407. (device (stat:dev (lstat file))))
  408. (when (= device root-device)
  409. (delete-file-recursively file)))))
  410. (scandir "/")))
  411. ;; Make ROOT the new root.
  412. (mount root "/" "" MS_MOVE)
  413. (chroot ".")
  414. (chdir "/")
  415. (when (file-exists? "/dev/console")
  416. ;; Close the standard file descriptors since they refer to the old
  417. ;; /dev/console, and reopen them.
  418. (let ((console (open-file "/dev/console" "r+b0")))
  419. (for-each close-fdes '(0 1 2))
  420. (dup2 (fileno console) 0)
  421. (dup2 (fileno console) 1)
  422. (dup2 (fileno console) 2)
  423. (close-port console))))
  424. (define* (boot-system #:key
  425. (linux-modules '())
  426. linux-module-directory
  427. keymap-file
  428. qemu-guest-networking?
  429. volatile-root?
  430. pre-mount
  431. (mounts '())
  432. (on-error 'debug))
  433. "This procedure is meant to be called from an initrd. Boot a system by
  434. first loading LINUX-MODULES (a list of module names) from
  435. LINUX-MODULE-DIRECTORY, then installing KEYMAP-FILE with 'loadkeys' (if
  436. KEYMAP-FILE is true), then setting up QEMU guest networking if
  437. QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
  438. specified in MOUNTS, and finally booting into the new root if any. The initrd
  439. supports the kernel command-line options 'gnu.load' and 'gnu.repl'. It also
  440. honors a subset of the Linux kernel command-line parameters such as
  441. 'fsck.mode', 'resume', 'rootdelay', rootflags and rootfstype.
  442. Mount the root file system, specified by the 'root' command-line argument, if
  443. any.
  444. MOUNTS must be a list of <file-system> objects.
  445. When VOLATILE-ROOT? is true, the root file system is writable but any changes
  446. to it are lost.
  447. ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
  448. upon error."
  449. (define (root-mount-point? fs)
  450. (string=? (file-system-mount-point fs) "/"))
  451. (define (device-string->file-system-device device-string)
  452. ;; The "root=SPEC" kernel command-line option always provides a string,
  453. ;; but the string can represent a device, an nfs-root, a UUID, or a label.
  454. ;; So check for all four.
  455. (cond ((string-prefix? "/" device-string) device-string)
  456. ((string-contains device-string ":/") device-string) ; nfs-root
  457. ((uuid device-string) => identity)
  458. (else (file-system-label device-string))))
  459. (display "Welcome, this is GNU's early boot Guile.\n")
  460. (display "Use 'gnu.repl' for an initrd REPL.\n\n")
  461. (call-with-error-handling
  462. (lambda ()
  463. (mount-essential-file-systems)
  464. (let* ((args (linux-command-line))
  465. (to-load (find-long-option "gnu.load" args))
  466. ;; If present, ‘root’ on the kernel command line takes precedence
  467. ;; over the ‘device’ field of the root <file-system> record.
  468. (root-device (and=> (find-long-option "root" args)
  469. device-string->file-system-device))
  470. (rootfstype (find-long-option "rootfstype" args))
  471. (rootflags (find-long-option "rootflags" args))
  472. (root-fs* (find root-mount-point? mounts))
  473. (fsck.mode (find-long-option "fsck.mode" args)))
  474. (unless (or root-fs* (and root-device rootfstype))
  475. (error "no root file system or 'root' and 'rootfstype' parameters"))
  476. ;; If present, ‘root’ on the kernel command line takes precedence over
  477. ;; the ‘device’ field of the root <file-system> record; likewise for
  478. ;; the 'rootfstype' and 'rootflags' arguments.
  479. (define root-fs
  480. (if root-fs*
  481. (file-system
  482. (inherit root-fs*)
  483. (device (or root-device (file-system-device root-fs*)))
  484. (type (or rootfstype (file-system-type root-fs*)))
  485. (options (or rootflags (file-system-options root-fs*))))
  486. (file-system
  487. (device root-device)
  488. (mount-point "/")
  489. (type rootfstype)
  490. (options rootflags))))
  491. (define (check? fs)
  492. (match fsck.mode
  493. ("skip" #f)
  494. ("force" #t)
  495. (_ (file-system-check? fs)))) ; assume "auto"
  496. (define (skip-check-if-clean? fs)
  497. (match fsck.mode
  498. ("force" #f)
  499. (_ (file-system-skip-check-if-clean? fs))))
  500. (define (repair fs)
  501. (let ((arg (find-long-option "fsck.repair" args)))
  502. (if arg
  503. (match arg
  504. ("no" #f)
  505. ("yes" #t)
  506. (_ 'preen))
  507. (file-system-repair fs))))
  508. (when (member "gnu.repl" args)
  509. (start-repl))
  510. (display "loading kernel modules...\n")
  511. (load-linux-modules-from-directory linux-modules
  512. linux-module-directory)
  513. (unless (or (member "hibernate=noresume" args)
  514. ;; Also handle the equivalent old-style argument.
  515. ;; See Documentation/admin-guide/kernel-parameters.txt.
  516. (member "noresume" args))
  517. ;; Try to resume immediately after loading (storage) modules
  518. ;; but before any on-disk file systems have been mounted.
  519. (false-if-exception ; failure is not fatal
  520. (resume-if-hibernated (find-long-option "resume" args))))
  521. (when keymap-file
  522. (let ((status (system* "loadkeys" keymap-file)))
  523. (unless (zero? status)
  524. ;; Emit a warning rather than abort when we cannot load
  525. ;; KEYMAP-FILE.
  526. (format (current-error-port)
  527. "warning: 'loadkeys' exited with status ~a~%"
  528. status))))
  529. (when qemu-guest-networking?
  530. (unless (configure-qemu-networking)
  531. (display "network interface is DOWN\n")))
  532. ;; A big ugly hammer, to be used only for debugging and in desperate
  533. ;; situations where no proper device synchonisation is possible.
  534. (let ((root-delay (and=> (find-long-option "rootdelay" args)
  535. string->number)))
  536. (when root-delay
  537. (format #t "Pausing for rootdelay=~a seconds before mounting \
  538. the root file system...\n" root-delay)
  539. (sleep root-delay)))
  540. ;; Prepare the real root file system under /root.
  541. (unless (file-exists? "/root")
  542. (mkdir "/root"))
  543. (when (procedure? pre-mount)
  544. ;; Do whatever actions are needed before mounting the root file
  545. ;; system--e.g., installing device mappings. Error out when the
  546. ;; return value is false.
  547. (unless (pre-mount)
  548. (error "pre-mount actions failed")))
  549. (setenv "EXT2FS_NO_MTAB_OK" "1")
  550. ;; Mount the root file system.
  551. (mount-root-file-system (canonicalize-device-spec
  552. (file-system-device root-fs))
  553. (file-system-type root-fs)
  554. #:volatile-root? volatile-root?
  555. #:flags (mount-flags->bit-mask
  556. (file-system-flags root-fs))
  557. #:options (file-system-options root-fs)
  558. #:check? (check? root-fs)
  559. #:skip-check-if-clean?
  560. (skip-check-if-clean? root-fs)
  561. #:repair (repair root-fs))
  562. ;; Mount the specified non-root file systems.
  563. (for-each (lambda (fs)
  564. (mount-file-system fs
  565. #:check? (check? fs)
  566. #:skip-check-if-clean?
  567. (skip-check-if-clean? fs)
  568. #:repair (repair fs)))
  569. (remove root-mount-point? mounts))
  570. (setenv "EXT2FS_NO_MTAB_OK" #f)
  571. (if to-load
  572. (begin
  573. (switch-root "/root")
  574. (format #t "loading '~a'...\n" to-load)
  575. (primitive-load to-load)
  576. (format (current-error-port)
  577. "boot program '~a' terminated, rebooting~%"
  578. to-load)
  579. (sleep 2)
  580. (reboot))
  581. (begin
  582. (display "no boot file passed via 'gnu.load'\n")
  583. (display "entering a warm and cozy REPL\n")
  584. (start-repl)))))
  585. #:on-error on-error))
  586. ;;; linux-boot.scm ends here