Merge branch 'master' into core-updates

9 files changed, 856 insertions, 200 deletions

diff --git a/guix/build/activation.scm b/guix/build/activation.scm
new file mode 100644
index 0000000000..62e69a9152
--- /dev/null
+++ b/guix/build/activation.scm
@@ -0,0 +1,219 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build activation)
+  #:use-module (guix build utils)
+  #:use-module (guix build linux-initrd)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (activate-users+groups
+            activate-etc
+            activate-setuid-programs
+            activate-current-system))
+
+;;; Commentary:
+;;;
+;;; This module provides "activation" helpers.  Activation is the process that
+;;; consists in setting up system-wide files and directories so that an
+;;; 'operating-system' configuration becomes active.
+;;;
+;;; Code:
+
+(define* (add-group name #:key gid password
+                    (log-port (current-error-port)))
+  "Add NAME as a user group, with the given numeric GID if specified."
+  ;; Use 'groupadd' from the Shadow package.
+  (format log-port "adding group '~a'...~%" name)
+  (let ((args `(,@(if gid `("-g" ,(number->string gid)) '())
+                ,@(if password `("-p" ,password) '())
+                ,name)))
+    (zero? (apply system* "groupadd" args))))
+
+(define* (add-user name group
+                   #:key uid comment home shell password
+                   (supplementary-groups '())
+                   (log-port (current-error-port)))
+  "Create an account for user NAME part of GROUP, with the specified
+properties.  Return #t on success."
+  (format log-port "adding user '~a'...~%" name)
+
+  (if (and uid (zero? uid))
+
+      ;; 'useradd' fails with "Cannot determine your user name" if the root
+      ;; account doesn't exist.  Thus, for bootstrapping purposes, create that
+      ;; one manually.
+      (begin
+        (call-with-output-file "/etc/shadow"
+          (cut format <> "~a::::::::~%" name))
+        (call-with-output-file "/etc/passwd"
+          (cut format <> "~a:x:~a:~a:~a:~a:~a~%"
+               name "0" "0" comment home shell))
+        (chmod "/etc/shadow" #o600)
+        #t)
+
+      ;; Use 'useradd' from the Shadow package.
+      (let ((args `(,@(if uid `("-u" ,(number->string uid)) '())
+                    "-g" ,(if (number? group) (number->string group) group)
+                    ,@(if (pair? supplementary-groups)
+                          `("-G" ,(string-join supplementary-groups ","))
+                          '())
+                    ,@(if comment `("-c" ,comment) '())
+                    ,@(if home
+                          (if (file-exists? home)
+                              `("-d" ,home)     ; avoid warning from 'useradd'
+                              `("-d" ,home "--create-home"))
+                          '())
+                    ,@(if shell `("-s" ,shell) '())
+                    ,@(if password `("-p" ,password) '())
+                    ,name)))
+        (zero? (apply system* "useradd" args)))))
+
+(define (activate-users+groups users groups)
+  "Make sure the accounts listed in USERS and the user groups listed in GROUPS
+are all available.
+
+Each item in USERS is a list of all the characteristics of a user account;
+each item in GROUPS is a tuple with the group name, group password or #f, and
+numeric gid or #f."
+  (define (touch file)
+    (call-with-output-file file (const #t)))
+
+  (define activate-user
+    (match-lambda
+     ((name uid group supplementary-groups comment home shell password)
+      (unless (false-if-exception (getpwnam name))
+        (let ((profile-dir (string-append "/var/guix/profiles/per-user/"
+                                          name)))
+          (add-user name group
+                    #:uid uid
+                    #:supplementary-groups supplementary-groups
+                    #:comment comment
+                    #:home home
+                    #:shell shell
+                    #:password password)
+
+          ;; Create the profile directory for the new account.
+          (let ((pw (getpwnam name)))
+            (mkdir-p profile-dir)
+            (chown profile-dir (passwd:uid pw) (passwd:gid pw))))))))
+
+  ;; 'groupadd' aborts if the file doesn't already exist.
+  (touch "/etc/group")
+
+  ;; Create the root account so we can use 'useradd' and 'groupadd'.
+  (activate-user (find (match-lambda
+                        ((name (? zero?) _ ...) #t)
+                        (_ #f))
+                       users))
+
+  ;; Then create the groups.
+  (for-each (match-lambda
+             ((name password gid)
+              (add-group name #:gid gid #:password password)))
+            groups)
+
+  ;; Finally create the other user accounts.
+  (for-each activate-user users))
+
+(define (activate-etc etc)
+  "Install ETC, a directory in the store, as the source of static files for
+/etc."
+
+  ;; /etc is a mixture of static and dynamic settings.  Here is where we
+  ;; initialize it from the static part.
+
+  (format #t "populating /etc from ~a...~%" etc)
+  (let ((rm-f (lambda (f)
+                (false-if-exception (delete-file f)))))
+    (rm-f "/etc/static")
+    (symlink etc "/etc/static")
+    (for-each (lambda (file)
+                ;; TODO: Handle 'shadow' specially so that changed
+                ;; password aren't lost.
+                (let ((target (string-append "/etc/" file))
+                      (source (string-append "/etc/static/" file)))
+                  (rm-f target)
+                  (symlink source target)))
+              (scandir etc
+                       (lambda (file)
+                         (not (member file '("." ".."))))
+
+                       ;; The default is 'string-locale<?', but we don't have
+                       ;; it when run from the initrd's statically-linked
+                       ;; Guile.
+                       string<?))
+
+    ;; Prevent ETC from being GC'd.
+    (rm-f "/var/guix/gcroots/etc-directory")
+    (symlink etc "/var/guix/gcroots/etc-directory")))
+
+(define %setuid-directory
+  ;; Place where setuid programs are stored.
+  "/run/setuid-programs")
+
+(define (activate-setuid-programs programs)
+  "Turn PROGRAMS, a list of file names, into setuid programs stored under
+%SETUID-DIRECTORY."
+  (define (make-setuid-program prog)
+    (let ((target (string-append %setuid-directory
+                                 "/" (basename prog))))
+      (catch 'system-error
+        (lambda ()
+          (link prog target))
+        (lambda args
+          ;; Perhaps PROG and TARGET live in a different file system, so copy
+          ;; PROG.
+          (copy-file prog target)))
+      (chown target 0 0)
+      (chmod target #o6555)))
+
+  (format #t "setting up setuid programs in '~a'...~%"
+          %setuid-directory)
+  (if (file-exists? %setuid-directory)
+      (for-each (compose delete-file
+                         (cut string-append %setuid-directory "/" <>))
+                (scandir %setuid-directory
+                         (lambda (file)
+                           (not (member file '("." ".."))))
+                         string<?))
+      (mkdir-p %setuid-directory))
+
+  (for-each make-setuid-program programs))
+
+(define %current-system
+  ;; The system that is current (a symlink.)  This is not necessarily the same
+  ;; as the system we booted (aka. /run/booted-system) because we can re-build
+  ;; a new system configuration and activate it, without rebooting.
+  "/run/current-system")
+
+(define (boot-time-system)
+  "Return the '--system' argument passed on the kernel command line."
+  (find-long-option "--system" (linux-command-line)))
+
+(define* (activate-current-system #:optional (system (boot-time-system)))
+  "Atomically make SYSTEM the current system."
+  (format #t "making '~a' the current system...~%" system)
+
+  ;; Atomically make SYSTEM current.
+  (let ((new (string-append %current-system ".new")))
+    (symlink system new)
+    (rename-file new %current-system)))
+
+;;; activation.scm ends here
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 75998568bc..144552e8de 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2014 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -48,6 +49,10 @@
 
     (let ((args `(,srcdir
                   ,(string-append "-DCMAKE_INSTALL_PREFIX=" out)
+                  ;; add input libraries to rpath
+                  "-DCMAKE_INSTALL_RPATH_USE_LINK_PATH=TRUE"
+                  ;; add (other) libraries of the project itself to rpath
+                  ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                   ,@configure-flags)))
       (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
       (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH"))
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 54115a9de2..d98933a907 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -167,8 +167,6 @@ which is not available during bootstrap."
 
           ;; Buffer input and output on this port.
           (setvbuf s _IOFBF)
-          ;; Enlarge the receive buffer.
-          (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
 
           (if (eq? 'https (uri-scheme uri))
               (tls-wrap s)
@@ -307,7 +305,10 @@ on success."
                uri)
        #f)))
 
-  (setvbuf (current-output-port) _IOLBF)
+  ;; Make this unbuffered so 'progress-proc' works as expected.  _IOLBF means
+  ;; '\n', not '\r', so it's not appropriate here.
+  (setvbuf (current-output-port) _IONBF)
+
   (setvbuf (current-error-port) _IOLBF)
 
   (let try ((uri uri))
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 4245594c38..68b132265b 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -31,6 +31,11 @@
                     #:key (git-command "git"))
   "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
 identifier.  Return #t on success, #f otherwise."
+
+  ;; Disable TLS certificate verification.  The hash of the checkout is known
+  ;; in advance anyway.
+  (setenv "GIT_SSL_NO_VERIFY" "true")
+
   (and (zero? (system* git-command "clone" url directory))
        (with-directory-excursion directory
          (system* git-command "tag" "-l")
diff --git a/guix/build/gnome.scm b/guix/build/gnome.scm
deleted file mode 100644
index cac4de8f24..0000000000
--- a/guix/build/gnome.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; GNU Guix is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; GNU Guix is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (guix build gnome)
-  #:export (gir-directory))
-
-;;; Commentary:
-;;;
-;;; Tools commonly used when building GNOME programs.
-;;;
-;;; Code:
-
-(define (gir-directory inputs pkg-name)
-  "Return the GIR directory name for PKG-NAME found from INPUTS."
-  (string-append (assoc-ref inputs pkg-name)
-                 "/share/gir-1.0"))
diff --git a/guix/build/install.scm b/guix/build/install.scm
new file mode 100644
index 0000000000..afa7d1dd8f
--- /dev/null
+++ b/guix/build/install.scm
@@ -0,0 +1,122 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build install)
+  #:use-module (guix build utils)
+  #:use-module (guix build install)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (install-grub
+            populate-root-file-system
+            reset-timestamps
+            register-closure))
+
+;;; Commentary:
+;;;
+;;; This module supports the installation of the GNU system on a hard disk.
+;;; It is meant to be used both in a build environment (in derivations that
+;;; build VM images), and on the bare metal (when really installing the
+;;; system.)
+;;;
+;;; Code:
+
+(define* (install-grub grub.cfg device mount-point)
+  "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
+MOUNT-POINT."
+  (let* ((target (string-append mount-point "/boot/grub/grub.cfg"))
+         (pivot  (string-append target ".new")))
+    (mkdir-p (dirname target))
+
+    ;; Copy GRUB.CFG instead of just symlinking it since it's not a GC root.
+    ;; Do that atomically.
+    (copy-file grub.cfg pivot)
+    (rename-file pivot target)
+
+    (unless (zero? (system* "grub-install" "--no-floppy"
+                            "--boot-directory"
+                            (string-append mount-point "/boot")
+                            device))
+      (error "failed to install GRUB"))))
+
+(define (evaluate-populate-directive directive target)
+  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
+directory TARGET."
+  (let loop ((directive directive))
+    (match directive
+      (('directory name)
+       (mkdir-p (string-append target name)))
+      (('directory name uid gid)
+       (let ((dir (string-append target name)))
+         (mkdir-p dir)
+         (chown dir uid gid)))
+      (('directory name uid gid mode)
+       (loop `(directory ,name ,uid ,gid))
+       (chmod (string-append target name) mode))
+      ((new '-> old)
+       (symlink old (string-append target new))))))
+
+(define (directives store)
+  "Return a list of directives to populate the root file system that will host
+STORE."
+  `((directory ,store 0 0)
+    (directory "/etc")
+    (directory "/var/log")                          ; for dmd
+    (directory "/var/guix/gcroots")
+    (directory "/var/empty")                        ; for no-login accounts
+    (directory "/var/run")
+    (directory "/run")
+    ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
+    ("/var/guix/gcroots/current-system" -> "/run/current-system")
+    (directory "/bin")
+    ("/bin/sh" -> "/run/current-system/profile/bin/bash")
+    (directory "/tmp" 0 0 #o1777)                 ; sticky bit
+    (directory "/var/guix/profiles/per-user/root" 0 0)
+
+    (directory "/root" 0 0)                       ; an exception
+    (directory "/home" 0 0)))
+
+(define (populate-root-file-system target)
+  "Make the essential non-store files and directories on TARGET.  This
+includes /etc, /var, /run, /bin/sh, etc."
+  (for-each (cut evaluate-populate-directive <> target)
+            (directives (%store-directory))))
+
+(define (reset-timestamps directory)
+  "Reset the timestamps of all the files under DIRECTORY, so that they appear
+as created and modified at the Epoch."
+  (display "clearing file timestamps...\n")
+  (for-each (lambda (file)
+              (let ((s (lstat file)))
+                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
+                ;; the timestamp of symlinks cannot be changed, and there are
+                ;; symlinks here pointing to /gnu/store, which is the host,
+                ;; read-only store.
+                (unless (eq? (stat:type s) 'symlink)
+                  (utime file 0 0 0 0))))
+            (find-files directory "")))
+
+(define (register-closure store closure)
+  "Register CLOSURE in STORE, where STORE is the directory name of the target
+store and CLOSURE is the name of a file containing a reference graph as used
+by 'guix-register'.  As a side effect, this resets timestamps on store files."
+  (let ((status (system* "guix-register" "--prefix" store
+                         closure)))
+    (unless (zero? status)
+      (error "failed to register store items" closure))))
+
+;;; install.scm ends here
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 61d4304b65..5be3c1ac2a 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -28,10 +28,11 @@
   #:use-module (guix build utils)
   #:export (mount-essential-file-systems
             linux-command-line
+            find-long-option
             make-essential-device-nodes
             configure-qemu-networking
-            mount-qemu-smb-share
-            mount-qemu-9p
+            check-file-system
+            mount-file-system
             bind-mount
             load-linux-module*
             device-number
@@ -63,12 +64,30 @@
     (mkdir (scope "sys")))
   (mount "none" (scope "sys") "sysfs"))
 
+(define (move-essential-file-systems root)
+  "Move currently mounted essential file systems to ROOT."
+  (for-each (lambda (dir)
+              (let ((target (string-append root dir)))
+                (unless (file-exists? target)
+                  (mkdir target))
+                (mount dir target "" MS_MOVE)))
+            '("/proc" "/sys")))
+
 (define (linux-command-line)
   "Return the Linux kernel command line as a list of strings."
   (string-tokenize
    (call-with-input-file "/proc/cmdline"
      get-string-all)))
 
+(define (find-long-option option arguments)
+  "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
+Return the value associated with OPTION, or #f on failure."
+  (let ((opt (string-append option "=")))
+    (and=> (find (cut string-prefix? opt <>)
+                 arguments)
+           (lambda (arg)
+             (substring arg (+ 1 (string-index arg #\=)))))))
+
 (define* (make-essential-device-nodes #:key (root "/"))
   "Make essential device nodes under ROOT/dev."
   ;; The hand-made udev!
@@ -115,6 +134,10 @@
                   (device-number 4 n))
            (loop (+ 1 n)))))
 
+  ;; Serial line.
+  (mknod (scope "dev/ttyS0") 'char-special #o660
+         (device-number 4 64))
+
   ;; Pseudo ttys.
   (mknod (scope "dev/ptmx") 'char-special #o666
          (device-number 5 2))
@@ -143,7 +166,18 @@
   (symlink "/proc/self/fd" (scope "dev/fd"))
   (symlink "/proc/self/fd/0" (scope "dev/stdin"))
   (symlink "/proc/self/fd/1" (scope "dev/stdout"))
-  (symlink "/proc/self/fd/2" (scope "dev/stderr")))
+  (symlink "/proc/self/fd/2" (scope "dev/stderr"))
+
+  ;; Loopback devices.
+  (let loop ((i 0))
+    (when (< i 8)
+      (mknod (scope (string-append "dev/loop" (number->string i)))
+             'block-special #o660
+             (device-number 7 i))
+      (loop (+ 1 i))))
+
+  ;; File systems in user space (FUSE).
+  (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 
 (define %host-qemu-ipv4-address
   (inet-pton AF_INET "10.0.2.10"))
@@ -167,33 +201,13 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 
     (logand (network-interface-flags sock interface) IFF_UP)))
 
-(define (mount-qemu-smb-share share mount-point)
-  "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT.
-
-Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
-`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares
- (the latter allows the store to be shared between the host and guest.)"
-
-  (format #t "mounting QEMU's SMB share `~a'...\n" share)
-  (let ((server "10.0.2.4"))
-    (mount (string-append "//" server share) mount-point "cifs" 0
-           (string->pointer "guest,sec=none"))))
-
-(define (mount-qemu-9p source mount-point)
-  "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT.
-
-This uses the 'virtio' transport, which requires the various virtio Linux
-modules to be loaded."
-
-  (format #t "mounting QEMU's 9p share '~a'...\n" source)
-  (let ((server "10.0.2.4"))
-    (mount source mount-point "9p" 0
-           (string->pointer "trans=virtio"))))
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY 1)
+(define MS_BIND 4096)
+(define MS_MOVE 8192)
 
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
-  (define MS_BIND 4096)                           ; from libc's <sys/mount.h>
-
   (mount source target "" MS_BIND))
 
 (define (load-linux-module* file)
@@ -208,6 +222,165 @@ modules to be loaded."
 the last argument of `mknod'."
   (+ (* major 256) minor))
 
+(define (pidof program)
+  "Return the PID of the first presumed instance of PROGRAM."
+  (let ((program (basename program)))
+    (find (lambda (pid)
+            (let ((exe (format #f "/proc/~a/exe" pid)))
+              (and=> (false-if-exception (readlink exe))
+                     (compose (cut string=? program <>) basename))))
+          (filter-map string->number (scandir "/proc")))))
+
+(define* (mount-root-file-system root type
+                                 #:key volatile-root? (unionfs "unionfs"))
+  "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
+is true, mount ROOT read-only and make it a union with a writable tmpfs using
+UNIONFS."
+  (define (mark-as-not-killable pid)
+    ;; Tell the 'user-processes' dmd service that PID must be kept alive when
+    ;; shutting down.
+    (mkdir-p "/root/etc/dmd")
+    (let ((port (open-file "/root/etc/dmd/do-not-kill" "a")))
+      (chmod port #o600)
+      (write pid port)
+      (newline port)
+      (close-port port)))
+
+  (catch #t
+    (lambda ()
+      (if volatile-root?
+          (begin
+            (mkdir-p "/real-root")
+            (mount root "/real-root" type MS_RDONLY)
+            (mkdir-p "/rw-root")
+            (mount "none" "/rw-root" "tmpfs")
+
+            ;; We want read-write /dev nodes.
+            (make-essential-device-nodes #:root "/rw-root")
+
+            ;; Make /root a union of the tmpfs and the actual root.
+            (unless (zero? (system* unionfs "-o"
+                                    "cow,allow_other,use_ino,suid,dev"
+                                    "/rw-root=RW:/real-root=RO"
+                                    "/root"))
+              (error "unionfs failed"))
+
+            ;; Make sure unionfs remains alive till the end.  Because
+            ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we
+            ;; have to resort to 'pidof' here.
+            (mark-as-not-killable (pidof unionfs)))
+          (begin
+            (check-file-system root type)
+            (mount root "/root" type))))
+    (lambda args
+      (format (current-error-port) "exception while mounting '~a': ~s~%"
+              root args)
+      (start-repl)))
+
+  (copy-file "/proc/mounts" "/root/etc/mtab"))
+
+(define (check-file-system device type)
+  "Run a file system check of TYPE on DEVICE."
+  (define fsck
+    (string-append "fsck." type))
+
+  (let ((status (system* fsck "-v" "-p" device)))
+    (match (status:exit-val status)
+      (0
+       #t)
+      (1
+       (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
+               fsck device))
+      (2
+       (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
+               fsck device)
+       (sleep 3)
+       (reboot))
+      (code
+       (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
+               fsck code device)
+       (start-repl)))))
+
+(define* (mount-file-system spec #:key (root "/root"))
+  "Mount the file system described by SPEC under ROOT.  SPEC must have the
+form:
+
+  (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
+
+DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
+FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
+run a file system check."
+  (define flags->bit-mask
+    (match-lambda
+     (('read-only rest ...)
+      (or MS_RDONLY (flags->bit-mask rest)))
+     (('bind-mount rest ...)
+      (or MS_BIND (flags->bit-mask rest)))
+     (()
+      0)))
+
+  (match spec
+    ((source mount-point type (flags ...) options check?)
+     (let ((mount-point (string-append root "/" mount-point)))
+       (when check?
+         (check-file-system source type))
+       (mkdir-p mount-point)
+       (mount source mount-point type (flags->bit-mask flags)
+              (if options
+                  (string->pointer options)
+                  %null-pointer))
+
+       ;; Update /etc/mtab.
+       (mkdir-p (string-append root "/etc"))
+       (let ((port (open-file (string-append root "/etc/mtab") "a")))
+         (format port "~a ~a ~a ~a 0 0~%"
+                 source mount-point type options)
+         (close-port port))))))
+
+(define (switch-root root)
+  "Switch to ROOT as the root file system, in a way similar to what
+util-linux' switch_root(8) does."
+  (move-essential-file-systems root)
+  (chdir root)
+
+  ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
+  ;; TODO: Use 'statfs' to check the fs type, like klibc does.
+  (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
+    (format (current-error-port)
+            "The root file system is probably not an initrd; \
+bailing out.~%root contents: ~s~%" (scandir "/"))
+    (force-output (current-error-port))
+    (exit 1))
+
+  ;; Delete files from the old root, without crossing mount points (assuming
+  ;; there are no mount points in sub-directories.)  That means we're leaving
+  ;; the empty ROOT directory behind us, but that's OK.
+  (let ((root-device (stat:dev (stat "/"))))
+    (for-each (lambda (file)
+                (unless (member file '("." ".."))
+                  (let* ((file   (string-append "/" file))
+                         (device (stat:dev (lstat file))))
+                    (when (= device root-device)
+                      (delete-file-recursively file)))))
+              (scandir "/")))
+
+  ;; Make ROOT the new root.
+  (mount root "/" "" MS_MOVE)
+  (chroot ".")
+  (chdir "/")
+
+  (when (file-exists? "/dev/console")
+    ;; Close the standard file descriptors since they refer to the old
+    ;; /dev/console, and reopen them.
+    (let ((console (open-file "/dev/console" "r+b0")))
+      (for-each close-fdes '(0 1 2))
+
+      (dup2 (fileno console) 0)
+      (dup2 (fileno console) 1)
+      (dup2 (fileno console) 2)
+
+      (close-port console))))
+
 (define* (boot-system #:key
                       (linux-modules '())
                       qemu-guest-networking?
@@ -220,9 +393,10 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
 and finally booting into the new root if any.  The initrd supports kernel
 command-line options '--load', '--root', and '--repl'.
 
-MOUNTS must be a list of elements of the form:
+Mount the root file system, specified by the '--root' command-line argument,
+if any.
 
-  (FILE-SYSTEM-TYPE SOURCE TARGET)
+MOUNTS must be a list suitable for 'mount-file-system'.
 
 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 the new root.
@@ -238,21 +412,25 @@ to it are lost."
             (resolve (string-append "/root" target)))
           file)))
 
-  (define MS_RDONLY 1)
+  (define root-mount-point?
+    (match-lambda
+     ((device "/" _ ...) #t)
+     (_ #f)))
+
+  (define root-fs-type
+    (or (any (match-lambda
+              ((device "/" type _ ...) type)
+              (_ #f))
+             mounts)
+        "ext4"))
 
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
 
   (mount-essential-file-systems)
   (let* ((args    (linux-command-line))
-         (option  (lambda (opt)
-                    (let ((opt (string-append opt "=")))
-                      (and=> (find (cut string-prefix? opt <>)
-                                   args)
-                             (lambda (arg)
-                               (substring arg (+ 1 (string-index arg #\=))))))))
-         (to-load (option "--load"))
-         (root    (option "--root")))
+         (to-load (find-long-option "--load" args))
+         (root    (find-long-option "--root" args)))
 
     (when (member "--repl" args)
       (start-repl))
@@ -273,55 +451,17 @@ to it are lost."
     (unless (file-exists? "/root")
       (mkdir "/root"))
     (if root
-        (catch #t
-          (lambda ()
-            (if volatile-root?
-                (begin
-                  ;; XXX: For lack of a union file system...
-                  (mkdir-p "/real-root")
-                  (mount root "/real-root" "ext3" MS_RDONLY)
-                  (mount "none" "/root" "tmpfs")
-
-                  ;; XXX: 'copy-recursively' cannot deal with device nodes, so
-                  ;; explicitly avoid /dev.
-                  (for-each (lambda (file)
-                              (unless (string=? "dev" file)
-                                (copy-recursively (string-append "/real-root/"
-                                                                 file)
-                                                  (string-append "/root/"
-                                                                 file)
-                                                  #:log (%make-void-port
-                                                         "w"))))
-                            (scandir "/real-root"
-                                     (lambda (file)
-                                       (not (member file '("." ".."))))))
-
-                  ;; TODO: Unmount /real-root.
-                  )
-                (mount root "/root" "ext3")))
-          (lambda args
-            (format (current-error-port) "exception while mounting '~a': ~s~%"
-                    root args)
-            (start-repl)))
+        (mount-root-file-system root root-fs-type
+                                #:volatile-root? volatile-root?)
         (mount "none" "/root" "tmpfs"))
 
-    (mount-essential-file-systems #:root "/root")
-
     (unless (file-exists? "/root/dev")
       (mkdir "/root/dev")
       (make-essential-device-nodes #:root "/root"))
 
     ;; Mount the specified file systems.
-    (for-each (match-lambda
-               (('cifs source target)
-                (let ((target (string-append "/root/" target)))
-                  (mkdir-p target)
-                  (mount-qemu-smb-share source target)))
-               (('9p source target)
-                (let ((target (string-append "/root/" target)))
-                  (mkdir-p target)
-                  (mount-qemu-9p source target))))
-              mounts)
+    (for-each mount-file-system
+              (remove root-mount-point? mounts))
 
     (when guile-modules-in-chroot?
       ;; Copy the directories that contain .scm and .go files so that the
@@ -338,9 +478,8 @@ to it are lost."
 
     (if to-load
         (begin
+          (switch-root "/root")
           (format #t "loading '~a'...\n" to-load)
-          (chdir "/root")
-          (chroot "/root")
 
           ;; 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)
@@ -352,9 +491,11 @@ to it are lost."
             (lambda ()
               (primitive-load to-load))
             (lambda args
+              (start-repl))
+            (lambda args
               (format (current-error-port) "'~a' raised an exception: ~s~%"
                       to-load args)
-              (start-repl)))
+              (display-backtrace (make-stack #t) (current-error-port))))
           (format (current-error-port)
                   "boot program '~a' terminated, rebooting~%"
                   to-load)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
new file mode 100644
index 0000000000..7a1bad7331
--- /dev/null
+++ b/guix/build/syscalls.scm
@@ -0,0 +1,183 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build syscalls)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:export (errno
+            MS_RDONLY
+            MS_REMOUNT
+            MS_BIND
+            MS_MOVE
+            mount
+            umount
+            processes))
+
+;;; Commentary:
+;;;
+;;; This module provides bindings to libc's syscall wrappers.  It uses the
+;;; FFI, and thus requires a dynamically-linked Guile.  (For statically-linked
+;;; Guile, we instead apply 'guile-linux-syscalls.patch'.)
+;;;
+;;; Code:
+
+(define %libc-errno-pointer
+  ;; Glibc's 'errno' pointer.
+  (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
+    (and errno-loc
+         (let ((proc (pointer->procedure '* errno-loc '())))
+           (proc)))))
+
+(define errno
+  (if %libc-errno-pointer
+      (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
+        (lambda ()
+          "Return the current errno."
+          ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
+          ;; In particular, that means that no async must be running here.
+
+          ;; Use one of the fixed-size native-ref procedures because they are
+          ;; optimized down to a single VM instruction, which reduces the risk
+          ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
+          (let-syntax ((ref (lambda (s)
+                              (syntax-case s ()
+                                ((_ bv)
+                                 (case (sizeof int)
+                                   ((4)
+                                    #'(bytevector-s32-native-ref bv 0))
+                                   ((8)
+                                    #'(bytevector-s64-native-ref bv 0))
+                                   (else
+                                    (error "unsupported 'int' size"
+                                           (sizeof int)))))))))
+            (ref bv))))
+      (lambda () 0)))
+
+(define (augment-mtab source target type options)
+  "Augment /etc/mtab with information about the given mount point."
+  (let ((port (open-file "/etc/mtab" "a")))
+    (format port "~a ~a ~a ~a 0 0~%"
+            source target type (or options "rw"))
+    (close-port port)))
+
+(define (read-mtab port)
+  "Read an mtab-formatted file from PORT, returning a list of tuples."
+  (let loop ((result '()))
+    (let ((line (read-line port)))
+      (if (eof-object? line)
+          (reverse result)
+          (loop (cons (string-tokenize line) result))))))
+
+(define (remove-from-mtab target)
+  "Remove mount point TARGET from /etc/mtab."
+  (define entries
+    (remove (match-lambda
+             ((device mount-point type options freq passno)
+              (string=? target mount-point))
+             (_ #f))
+            (call-with-input-file "/etc/fstab" read-mtab)))
+
+  (call-with-output-file "/etc/fstab"
+    (lambda (port)
+      (for-each (match-lambda
+                 ((device mount-point type options freq passno)
+                  (format port "~a ~a ~a ~a ~a ~a~%"
+                          device mount-point type options freq passno)))
+                entries))))
+
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY      1)
+(define MS_REMOUNT    32)
+(define MS_BIND     4096)
+(define MS_MOVE     8192)
+
+(define mount
+  (let* ((ptr  (dynamic-func "mount" (dynamic-link)))
+         (proc (pointer->procedure int ptr `(* * * ,unsigned-long *))))
+    (lambda* (source target type #:optional (flags 0) options
+                     #:key (update-mtab? #t))
+      "Mount device SOURCE on TARGET as a file system TYPE.  Optionally, FLAGS
+may be a bitwise-or of the MS_* <sys/mount.h> constants, and OPTIONS may be a
+string.  When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored.  When
+UPDATE-MTAB? is true, update /etc/mtab.  Raise a 'system-error' exception on
+error."
+      (let ((ret (proc (if source
+                           (string->pointer source)
+                           %null-pointer)
+                       (string->pointer target)
+                       (if type
+                           (string->pointer type)
+                           %null-pointer)
+                       flags
+                       (if options
+                           (string->pointer options)
+                           %null-pointer)))
+            (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                 (list source target (strerror err))
+                 (list err)))
+        (when update-mtab?
+          (augment-mtab source target type options))))))
+
+(define umount
+  (let* ((ptr  (dynamic-func "umount2" (dynamic-link)))
+         (proc (pointer->procedure int ptr `(* ,int))))
+    (lambda* (target #:optional (flags 0)
+                     #:key (update-mtab? #t))
+      "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
+constants from <sys/mount.h>."
+      (let ((ret (proc (string->pointer target) flags))
+            (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "umount" "~S: ~A"
+                 (list target (strerror err))
+                 (list err)))
+        (when update-mtab?
+          (remove-from-mtab target))))))
+
+(define (kernel? pid)
+  "Return #t if PID designates a \"kernel thread\" rather than a normal
+user-land process."
+  (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
+                (compose string-tokenize read-string))))
+    ;; See proc.txt in Linux's documentation for the list of fields.
+    (match stat
+      ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
+            cmin_flt maj_flt cmaj_flt utime stime cutime cstime
+            priority nice num_thread it_real_value start_time
+            vsize rss rsslim
+            (= string->number start_code) (= string->number end_code) _ ...)
+       ;; Got this obscure trick from sysvinit's 'killall5' program.
+       (and (zero? start_code) (zero? end_code))))))
+
+(define (processes)
+  "Return the list of live processes."
+  (sort (filter-map (lambda (file)
+                      (let ((pid (string->number file)))
+                        (and pid
+                             (not (kernel? pid))
+                             pid)))
+                    (scandir "/proc"))
+        <))
+
+;;; syscalls.scm ends here
diff --git a/guix/build/vm.scm b/guix/build/vm.scm
index 33c898d968..e559542f0a 100644
--- a/guix/build/vm.scm
+++ b/guix/build/vm.scm
@@ -19,11 +19,15 @@
 (define-module (guix build vm)
   #:use-module (guix build utils)
   #:use-module (guix build linux-initrd)
+  #:use-module (guix build install)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (load-in-linux-vm
+            format-partition
+            initialize-root-partition
+            initialize-partition-table
             initialize-hard-disk))
 
 ;;; Commentary:
@@ -46,6 +50,7 @@
                            (qemu (qemu-command)) (memory-size 512)
                            linux initrd
                            make-disk-image? (disk-image-size 100)
+                           (disk-image-format "qcow2")
                            (references-graphs '()))
   "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy
 the result to OUTPUT.
@@ -56,9 +61,12 @@ it via /dev/hda.
 
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
+  (define image-file
+    (string-append "image." disk-image-format))
 
   (when make-disk-image?
-    (unless (zero? (system* "qemu-img" "create" "-f" "qcow2" "image.qcow2"
+    (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format
+                            image-file
                             (number->string disk-image-size)))
       (error "qemu-img failed")))
 
@@ -88,13 +96,13 @@ the #:references-graphs parameter of 'derivation'."
                   "-append" (string-append "console=ttyS0 --load="
                                            builder)
                   (if make-disk-image?
-                      '("-hda" "image.qcow2")
+                      `("-drive" ,(string-append "file=" image-file
+                                                 ",if=virtio"))
                       '())))
     (error "qemu failed" qemu))
 
   (if make-disk-image?
-      (copy-file "image.qcow2"            ; XXX: who mkdir'd OUTPUT?
-                 output)
+      (copy-file image-file output)
       (begin
         (mkdir output)
         (copy-recursively "xchg" output))))
@@ -113,25 +121,20 @@ The data at PORT is the format produced by #:references-graphs."
            (loop (read-line port)
                  result)))))
 
-(define* (initialize-partition-table device
+(define* (initialize-partition-table device partition-size
                                      #:key
                                      (label-type "msdos")
-                                     partition-size)
+                                     (offset (expt 2 20)))
   "Create on DEVICE a partition table of type LABEL-TYPE, with a single
-partition of PARTITION-SIZE MiB.  Return #t on success."
-  (display "creating partition table...\n")
-  (zero? (system* "parted" "/dev/sda" "mklabel" label-type
-                  "mkpart" "primary" "ext2" "1MiB"
-                  (format #f "~aB" partition-size))))
-
-(define* (install-grub grub.cfg device mount-point)
-  "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on
-MOUNT-POINT.  Return #t on success."
-  (mkdir-p (string-append mount-point "/boot/grub"))
-  (symlink grub.cfg (string-append mount-point "/boot/grub/grub.cfg"))
-  (zero? (system* "grub-install" "--no-floppy"
-                  "--boot-directory" (string-append mount-point "/boot")
-                  device)))
+partition of PARTITION-SIZE bytes starting at OFFSET bytes.  Return #t on
+success."
+  (format #t "creating partition table with a ~a B partition...\n"
+          partition-size)
+  (unless (zero? (system* "parted" device "mklabel" label-type
+                          "mkpart" "primary" "ext2"
+                          (format #f "~aB" offset)
+                          (format #f "~aB" partition-size)))
+    (error "failed to create partition table")))
 
 (define* (populate-store reference-graphs target)
   "Populate the store under directory TARGET with the items specified in
@@ -153,80 +156,88 @@ REFERENCE-GRAPHS, a list of reference-graph files."
                                 (string-append target thing)))
             (things-to-copy)))
 
-(define (evaluate-populate-directive directive target)
-  "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
-directory TARGET."
-  (match directive
-    (('directory name)
-     (mkdir-p (string-append target name)))
-    (('directory name uid gid)
-     (let ((dir (string-append target name)))
-       (mkdir-p dir)
-       (chown dir uid gid)))
-    ((new '-> old)
-     (symlink old (string-append target new)))))
-
-(define (reset-timestamps directory)
-  "Reset the timestamps of all the files under DIRECTORY, so that they appear
-as created and modified at the Epoch."
-  (display "clearing file timestamps...\n")
-  (for-each (lambda (file)
-              (let ((s (lstat file)))
-                ;; XXX: Guile uses libc's 'utime' function (not 'futime'), so
-                ;; the timestamp of symlinks cannot be changed, and there are
-                ;; symlinks here pointing to /gnu/store, which is the host,
-                ;; read-only store.
-                (unless (eq? (stat:type s) 'symlink)
-                  (utime file 0 0 0 0))))
-            (find-files directory "")))
-
-(define* (initialize-hard-disk #:key
-                               grub.cfg
-                               disk-image-size
-                               (mkfs "mkfs.ext3")
-                               initialize-store?
-                               (closures-to-copy '())
-                               (directives '()))
-  (unless (initialize-partition-table "/dev/sda"
-                                      #:partition-size
-                                      (- disk-image-size (* 5 (expt 2 20))))
-    (error "failed to create partition table"))
-
-  (display "creating ext3 partition...\n")
-  (unless (zero? (system* mkfs "-F" "/dev/sda1"))
-    (error "failed to create partition"))
+(define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
-  (display "mounting partition...\n")
-  (mkdir "/fs")
-  (mount "/dev/sda1" "/fs" "ext3")
+(define (format-partition partition type)
+  "Create a file system TYPE on PARTITION."
+  (format #t "creating ~a partition...\n" type)
+  (unless (zero? (system* (string-append "mkfs." type) "-F" partition))
+    (error "failed to create partition")))
 
-  (when (pair? closures-to-copy)
+(define* (initialize-root-partition target-directory
+                                    #:key copy-closures? register-closures?
+                                    closures)
+  "Initialize the root partition mounted at TARGET-DIRECTORY."
+  (define target-store
+    (string-append target-directory (%store-directory)))
+
+  (when copy-closures?
     ;; Populate the store.
-    (populate-store (map (cut string-append "/xchg/" <>)
-                         closures-to-copy)
-                    "/fs"))
+    (populate-store (map (cut string-append "/xchg/" <>) closures)
+                    target-directory))
 
   ;; Populate /dev.
-  (make-essential-device-nodes #:root "/fs")
+  (make-essential-device-nodes #:root target-directory)
 
   ;; Optionally, register the inputs in the image's store.
-  (when initialize-store?
+  (when register-closures?
+    (unless copy-closures?
+      ;; XXX: 'guix-register' wants to palpate the things it registers, so
+      ;; bind-mount the store on the target.
+      (mkdir-p target-store)
+      (mount (%store-directory) target-store "" MS_BIND))
+
+    (display "registering closures...\n")
     (for-each (lambda (closure)
-                (let ((status (system* "guix-register" "--prefix" "/fs"
-                                       (string-append "/xchg/" closure))))
-                  (unless (zero? status)
-                    (error "failed to register store items" closure))))
-              closures-to-copy))
+                (register-closure target-directory
+                                  (string-append "/xchg/" closure)))
+              closures)
+    (unless copy-closures?
+      (system* "umount" target-store)))
+
+  ;; Add the non-store directories and files.
+  (display "populating...\n")
+  (populate-root-file-system target-directory))
+
+(define* (initialize-hard-disk device
+                               #:key
+                               grub.cfg
+                               disk-image-size
+                               (file-system-type "ext4")
+                               (closures '())
+                               copy-closures?
+                               (register-closures? #t))
+  "Initialize DEVICE, a disk of DISK-IMAGE-SIZE bytes, with a
+FILE-SYSTEM-TYPE partition, and with GRUB installed.  If REGISTER-CLOSURES? is
+true, register all of CLOSURES is the partition's store.  If COPY-CLOSURES? is
+true, copy all of CLOSURES to the partition."
+  (define target-directory
+    "/fs")
+
+  (define partition
+    (string-append device "1"))
+
+  (initialize-partition-table device
+                              (- disk-image-size (* 5 (expt 2 20))))
+
+  (format-partition partition file-system-type)
+
+  (display "mounting partition...\n")
+  (mkdir target-directory)
+  (mount partition target-directory file-system-type)
 
-  ;; Evaluate the POPULATE directives.
-  (for-each (cut evaluate-populate-directive <> "/fs")
-            directives)
+  (initialize-root-partition target-directory
+                             #:copy-closures? copy-closures?
+                             #:register-closures? register-closures?
+                             #:closures closures)
 
-  (unless (install-grub grub.cfg "/dev/sda" "/fs")
-    (error "failed to install GRUB"))
+  (install-grub grub.cfg device target-directory)
 
-  (reset-timestamps "/fs")
+  ;; 'guix-register' resets timestamps and everything, so no need to do it
+  ;; once more in that case.
+  (unless register-closures?
+    (reset-timestamps target-directory))
 
-  (zero? (system* "umount" "/fs")))
+  (zero? (system* "umount" target-directory)))
 
 ;;; vm.scm ends here