Merge branch 'master' into staging

18 files changed, 1056 insertions, 308 deletions

diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index 7ff4e90f71..dc137421e9 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -59,13 +59,17 @@ to NAME and VERSION."
 (define %cargo-build-system-modules
   ;; Build-side modules imported by default.
   `((guix build cargo-build-system)
+    (json parser)
     ,@%cargo-utils-modules))
 
 (define* (cargo-build store name inputs
                       #:key
                       (tests? #t)
                       (test-target #f)
+                      (vendor-dir "guix-vendor")
                       (cargo-build-flags ''("--release"))
+                      (cargo-test-flags ''("--release"))
+                      (skip-build? #f)
                       (phases '(@ (guix build cargo-build-system)
                                   %standard-phases))
                       (outputs '("out"))
@@ -90,8 +94,11 @@ to NAME and VERSION."
                                  source))
                     #:system ,system
                     #:test-target ,test-target
+                    #:vendor-dir ,vendor-dir
                     #:cargo-build-flags ,cargo-build-flags
-                    #:tests? ,tests?
+                    #:cargo-test-flags ,cargo-test-flags
+                    #:skip-build? ,skip-build?
+                    #:tests? ,(and tests? (not skip-build?))
                     #:phases ,phases
                     #:outputs %outputs
                     #:search-paths ',(map search-path-specification->sexp
diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
new file mode 100644
index 0000000000..6084d22210
--- /dev/null
+++ b/guix/build-system/linux-module.scm
@@ -0,0 +1,175 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.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-system linux-module)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix packages)
+  #:use-module (ice-9 match)
+  #:export (%linux-module-build-system-modules
+            linux-module-build
+            linux-module-build-system))
+
+;; Commentary:
+;;
+;; Code:
+
+(define %linux-module-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build linux-module-build-system)
+    ,@%gnu-build-system-modules))
+
+(define (default-linux)
+  "Return the default Linux package."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(gnu packages linux))))
+    (module-ref module 'linux-libre)))
+
+(define (default-kmod)
+  "Return the default kmod package."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(gnu packages linux))))
+    (module-ref module 'kmod)))
+
+(define (default-gcc)
+  "Return the default gcc package."
+
+  ;; Do not use `@' to avoid introducing circular dependencies.
+  (let ((module (resolve-interface '(gnu packages gcc))))
+    (module-ref module 'gcc-7)))
+
+(define (make-linux-module-builder linux)
+  (package
+    (inherit linux)
+    (name (string-append (package-name linux) "-module-builder"))
+    (native-inputs
+     `(("linux" ,linux)
+       ,@(package-native-inputs linux)))
+    (arguments
+     (substitute-keyword-arguments (package-arguments linux)
+      ((#:phases phases)
+       `(modify-phases ,phases
+          (replace 'build
+            (lambda _
+              (invoke "make" "modules_prepare")))
+          (delete 'strip) ; faster.
+          (replace 'install
+            (lambda* (#:key inputs outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (out-lib-build (string-append out "/lib/modules/build")))
+                ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config".
+                (copy-recursively "." out-lib-build)
+                (let* ((linux (assoc-ref inputs "linux")))
+                  (install-file (string-append linux "/System.map")
+                                out-lib-build)
+                  (let ((source (string-append linux "/Module.symvers")))
+                    (if (file-exists? source)
+                        (install-file source out-lib-build))))
+                #t)))))))))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs
+                system target
+                (linux (default-linux))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs))
+
+  (and (not target)                               ;XXX: no cross-compilation
+       (bag
+         (name name)
+         (system system)
+         (host-inputs `(,@(if source
+                              `(("source" ,source))
+                              '())
+                        ,@inputs
+                        ,@(standard-packages)))
+         (build-inputs `(("linux" ,linux) ; for "Module.symvers".
+                         ("linux-module-builder"
+                         ,(make-linux-module-builder linux))
+                         ,@native-inputs
+                         ;; TODO: Remove "gmp", "mpfr", "mpc" since they are only needed to compile the gcc plugins.  Maybe remove "flex", "bison", "elfutils", "perl", "openssl".  That leaves very little ("bc", "gcc", "kmod").
+                         ,@(package-native-inputs linux)))
+         (outputs outputs)
+         (build linux-module-build)
+         (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (linux-module-build store name inputs
+                             #:key
+                             (search-paths '())
+                             (tests? #t)
+                             (phases '(@ (guix build linux-module-build-system)
+                                         %standard-phases))
+                             (outputs '("out"))
+                             (system (%current-system))
+                             (guile #f)
+                             (imported-modules
+                              %linux-module-build-system-modules)
+                             (modules '((guix build linux-module-build-system)
+                                        (guix build utils))))
+  "Build SOURCE using LINUX, and with INPUTS."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (linux-module-build #:name ,name
+                     #:source ,(match (assoc-ref inputs "source")
+                                      (((? derivation? source))
+                                       (derivation->output-path source))
+                                      ((source)
+                                       source)
+                                      (source
+                                        source))
+                     #:search-paths ',(map search-path-specification->sexp
+                                           search-paths)
+                     #:phases ,phases
+                     #:system ,system
+                     #:tests? ,tests?
+                     #:outputs %outputs
+                     #:inputs %build-inputs)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                                         ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:system system
+                                #:inputs inputs
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define linux-module-build-system
+  (build-system
+    (name 'linux-module)
+    (description "The Linux module build system")
+    (lower lower)))
+
+;;; linux-module.scm ends here
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 20087fa6c4..b68a1f90d2 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (json parser)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (%standard-phases
@@ -37,81 +39,86 @@
 ;;
 ;; Code:
 
-;; FIXME: Needs to be parsed from url not package name.
-(define (package-name->crate-name name)
-  "Return the crate name of NAME."
-  (match (string-split name #\-)
-    (("rust" rest ...)
-     (string-join rest "-"))
-    (_ #f)))
-
-(define* (configure #:key inputs #:allow-other-keys)
-  "Replace Cargo.toml [dependencies] section with guix inputs."
-  ;; Make sure Cargo.toml is writeable when the crate uses git-fetch.
-  (chmod "Cargo.toml" #o644)
+(define (manifest-targets)
+  "Extract all targets from the Cargo.toml manifest"
+  (let* ((port (open-input-pipe "cargo read-manifest"))
+         (data (json->scm port))
+         (targets (hash-ref data "targets" '())))
+    (close-port port)
+    targets))
+
+(define (has-executable-target?)
+  "Check if the current cargo project declares any binary targets."
+  (let* ((bin? (lambda (kind) (string=? kind "bin")))
+         (get-kinds (lambda (dep) (hash-ref dep "kind")))
+         (bin-dep? (lambda (dep) (find bin? (get-kinds dep)))))
+    (find bin-dep? (manifest-targets))))
+
+(define* (configure #:key inputs
+                    (vendor-dir "guix-vendor")
+                    #:allow-other-keys)
+  "Vendor Cargo.toml dependencies as guix inputs."
   (chmod "." #o755)
-  (if (not (file-exists? "vendor"))
-    (if (not (file-exists? "Cargo.lock"))
-      (begin
-        (substitute* "Cargo.toml"
-          ((".*32-sys.*") "
-")
-          ((".*winapi.*") "
-")
-          ((".*core-foundation.*") "
-"))
-        ;; Prepare one new directory with all the required dependencies.
-        ;; It's necessary to do this (instead of just using /gnu/store as the
-        ;; directory) because we want to hide the libraries in subdirectories
-        ;;   share/rust-source/... instead of polluting the user's profile root.
-        (mkdir "vendor")
-        (for-each
-          (match-lambda
-            ((name . path)
-             (let ((crate (package-name->crate-name name)))
-               (when (and crate path)
-                 (match (string-split (basename path) #\-)
-                   ((_ ... version)
-                    (symlink (string-append path "/share/rust-source")
-                             (string-append "vendor/" (basename path)))))))))
-          inputs)
-        ;; Configure cargo to actually use this new directory.
-        (mkdir-p ".cargo")
-        (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8")))
-          (display "
+  ;; Prepare one new directory with all the required dependencies.
+  ;; It's necessary to do this (instead of just using /gnu/store as the
+  ;; directory) because we want to hide the libraries in subdirectories
+  ;; share/rust-source/... instead of polluting the user's profile root.
+  (mkdir-p vendor-dir)
+  (for-each
+    (match-lambda
+      ((name . path)
+       (let* ((rust-share (string-append path "/share/rust-source"))
+              (basepath (basename path))
+              (link-dir (string-append vendor-dir "/" basepath)))
+         (and (file-exists? rust-share)
+              ;; Gracefully handle duplicate inputs
+              (not (file-exists? link-dir))
+              (symlink rust-share link-dir)))))
+    inputs)
+  ;; Configure cargo to actually use this new directory.
+  (mkdir-p ".cargo")
+  (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8")))
+    (display "
 [source.crates-io]
-registry = 'https://github.com/rust-lang/crates.io-index'
 replace-with = 'vendored-sources'
 
 [source.vendored-sources]
 directory = '" port)
-          (display (getcwd) port)
-          (display "/vendor" port)
-          (display "'
+    (display (string-append (getcwd) "/" vendor-dir) port)
+    (display "'
 " port)
-          (close-port port)))))
-    (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
+    (close-port port))
 
-    ;(setenv "CARGO_HOME" "/gnu/store")
-    ; (setenv "CMAKE_C_COMPILER" cc)
+  ;; Lift restriction on any lints: a crate author may have decided to opt
+  ;; into stricter lints (e.g. #![deny(warnings)]) during their own builds
+  ;; but we don't want any build failures that could be caused later by
+  ;; upgrading the compiler for example.
+  (setenv "RUSTFLAGS" "--cap-lints allow")
+  (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
   #t)
 
-(define* (build #:key (cargo-build-flags '("--release"))
+(define* (build #:key
+                skip-build?
+                (cargo-build-flags '("--release"))
                 #:allow-other-keys)
   "Build a given Cargo package."
-  (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))))
+  (or skip-build?
+      (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))))
 
-(define* (check #:key tests? #:allow-other-keys)
+(define* (check #:key
+                tests?
+                (cargo-test-flags '("--release"))
+                #:allow-other-keys)
   "Run tests for a given Cargo package."
-  (if (and tests? (file-exists? "Cargo.lock"))
-      (zero? (system* "cargo" "test"))
+  (if tests?
+      (zero? (apply system* `("cargo" "test" ,@cargo-test-flags)))
       #t))
 
 (define (touch file-name)
   (call-with-output-file file-name (const #t)))
 
-(define* (install #:key inputs outputs #:allow-other-keys)
-  "Install a given Cargo package."
+(define* (install-source #:key inputs outputs #:allow-other-keys)
+  "Install the source for a given Cargo package."
   (let* ((out (assoc-ref outputs "out"))
          (src (assoc-ref inputs "source"))
          (rsrc (string-append (assoc-ref outputs "src")
@@ -120,24 +127,36 @@ directory = '" port)
     ;; Rust doesn't have a stable ABI yet. Because of this
     ;; Cargo doesn't have a search path for binaries yet.
     ;; Until this changes we are working around this by
-    ;; distributing crates as source and replacing
-    ;; references in Cargo.toml with store paths.
-    (copy-recursively "src" (string-append rsrc "/src"))
+    ;; vendoring the crates' sources by symlinking them
+    ;; to store paths.
+    (copy-recursively "." rsrc)
     (touch (string-append rsrc "/.cargo-ok"))
-    (generate-checksums rsrc src)
+    (generate-checksums rsrc "/dev/null")
     (install-file "Cargo.toml" rsrc)
-    ;; When the package includes executables we install
-    ;; it using cargo install. This fails when the crate
-    ;; doesn't contain an executable.
-    (if (file-exists? "Cargo.lock")
-        (zero? (system* "cargo" "install" "--root" out))
-        (begin
-          (mkdir out)
-          #t))))
+    #t))
+
+(define* (install #:key inputs outputs skip-build? #:allow-other-keys)
+  "Install a given Cargo package."
+  (let* ((out (assoc-ref outputs "out")))
+    (mkdir-p out)
+
+    ;; Make cargo reuse all the artifacts we just built instead
+    ;; of defaulting to making a new temp directory
+    (setenv "CARGO_TARGET_DIR" "./target")
+    ;; Force cargo to honor our .cargo/config definitions
+    ;; https://github.com/rust-lang/cargo/issues/6397
+    (setenv "CARGO_HOME" ".")
+
+    ;; Only install crates which include binary targets,
+    ;; otherwise cargo will raise an error.
+    (or skip-build?
+        (not (has-executable-target?))
+        (zero? (system* "cargo" "install" "--path" "." "--root" out)))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
     (delete 'bootstrap)
+    (add-before 'configure 'install-source install-source)
     (replace 'configure configure)
     (replace 'build build)
     (replace 'check check)
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
new file mode 100644
index 0000000000..cd76df2de7
--- /dev/null
+++ b/guix/build/linux-module-build-system.scm
@@ -0,0 +1,91 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.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 linux-module-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (%standard-phases
+            linux-module-build))
+
+;; Commentary:
+;;
+;; Builder-side code of linux-module build.
+;;
+;; Code:
+
+;; Copied from make-linux-libre's "configure" phase.
+(define* (configure #:key inputs target #:allow-other-keys)
+  (setenv "KCONFIG_NOTIMESTAMP" "1")
+  (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
+  ;(let ((arch ,(system->linux-architecture
+  ;                         (or (%current-target-system)
+  ;                             (%current-system)))))
+  ;  (setenv "ARCH" arch)
+  ;  (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")))
+  (when target
+    (setenv "CROSS_COMPILE" (string-append target "-"))
+    (format #t "`CROSS_COMPILE' set to `~a'~%"
+               (getenv "CROSS_COMPILE")))
+  ; TODO: (setenv "EXTRA_VERSION" ,extra-version)
+  ; TODO: kernel ".config".
+  #t)
+
+(define* (build #:key inputs make-flags #:allow-other-keys)
+  (apply invoke "make" "-C"
+         (string-append (assoc-ref inputs "linux-module-builder")
+                        "/lib/modules/build")
+         (string-append "M=" (getcwd))
+         (or make-flags '())))
+
+;; This block was copied from make-linux-libre--only took the "modules_install"
+;; part.
+(define* (install #:key inputs native-inputs outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (moddir (string-append out "/lib/modules"))
+         (kmod (assoc-ref (or native-inputs inputs) "kmod")))
+    ;; Install kernel modules
+    (mkdir-p moddir)
+    (invoke "make" "-C"
+            (string-append (assoc-ref inputs "linux-module-builder")
+                           "/lib/modules/build")
+            (string-append "M=" (getcwd))
+            (string-append "DEPMOD=" kmod "/bin/depmod")
+            (string-append "MODULE_DIR=" moddir)
+            (string-append "INSTALL_PATH=" out)
+            (string-append "INSTALL_MOD_PATH=" out)
+            "INSTALL_MOD_STRIP=1"
+            "modules_install")))
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (replace 'configure configure)
+    (replace 'build build)
+    (replace 'install install)))
+
+(define* (linux-module-build #:key inputs (phases %standard-phases)
+                       #:allow-other-keys #:rest args)
+  "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance."
+  (apply gnu:gnu-build
+         #:inputs inputs #:phases phases
+         args))
+
+;;; linux-module-build-system.scm ends here
diff --git a/guix/colors.scm b/guix/colors.scm
new file mode 100644
index 0000000000..7949cf5763
--- /dev/null
+++ b/guix/colors.scm
@@ -0,0 +1,188 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
+;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018, 2019 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 colors)
+  #:use-module (guix memoization)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:export (color
+            color?
+
+            colorize-string
+            highlight
+            color-rules
+            color-output?
+            isatty?*))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to produce colored output using ANSI escapes.
+;;;
+;;; Code:
+
+;; Record type for "colors", which are actually lists of color attributes.
+(define-record-type <color>
+  (make-color symbols ansi)
+  color?
+  (symbols  color-symbols)
+  (ansi     color-ansi))
+
+(define (print-color color port)
+  (format port "#<color ~a>"
+          (string-join (map symbol->string
+                            (color-symbols color)))))
+
+(set-record-type-printer! <color> print-color)
+
+(define-syntax define-color-table
+  (syntax-rules ()
+    "Define NAME as a macro that builds a list of color attributes."
+    ((_ name (color escape) ...)
+     (begin
+       (define-syntax color-codes
+         (syntax-rules (color ...)
+           ((_)
+            '())
+           ((_ color rest (... ...))
+            `(escape ,@(color-codes rest (... ...))))
+           ...))
+
+       (define-syntax-rule (name colors (... ...))
+         "Return a list of color attributes that can be passed to
+'colorize-string'."
+         (make-color '(colors (... ...))
+                     (color-codes->ansi (color-codes colors (... ...)))))))))
+
+(define-color-table color
+  (CLEAR        "0")
+  (RESET        "0")
+  (BOLD         "1")
+  (DARK         "2")
+  (UNDERLINE    "4")
+  (UNDERSCORE   "4")
+  (BLINK        "5")
+  (REVERSE      "6")
+  (CONCEALED    "8")
+  (BLACK       "30")
+  (RED         "31")
+  (GREEN       "32")
+  (YELLOW      "33")
+  (BLUE        "34")
+  (MAGENTA     "35")
+  (CYAN        "36")
+  (WHITE       "37")
+  (ON-BLACK    "40")
+  (ON-RED      "41")
+  (ON-GREEN    "42")
+  (ON-YELLOW   "43")
+  (ON-BLUE     "44")
+  (ON-MAGENTA  "45")
+  (ON-CYAN     "46")
+  (ON-WHITE    "47"))
+
+(define (color-codes->ansi codes)
+  "Convert CODES, a list of color attribute codes, to a ANSI escape string."
+  (match codes
+    (()
+     "")
+    (_
+     (string-append (string #\esc #\[)
+                    (string-join codes ";" 'infix)
+                    "m"))))
+
+(define %reset
+  (color RESET))
+
+(define (colorize-string str color)
+  "Return a copy of STR colorized using ANSI escape sequences according to
+COLOR.  At the end of the returned string, the color attributes are reset such
+that subsequent output will not have any colors in effect."
+  (string-append (color-ansi color)
+                 str
+                 (color-ansi %reset)))
+
+(define isatty?*
+  (mlambdaq (port)
+    "Return true if PORT is a tty.  Memoize the result."
+    (isatty? port)))
+
+(define (color-output? port)
+  "Return true if we should write colored output to PORT."
+  (and (not (getenv "INSIDE_EMACS"))
+       (not (getenv "NO_COLOR"))
+       (isatty?* port)))
+
+(define %highlight-color (color BOLD))
+
+(define* (highlight str #:optional (port (current-output-port)))
+  "Return STR with extra ANSI color attributes to highlight it if PORT
+supports it."
+  (if (color-output? port)
+      (colorize-string str %highlight-color)
+      str))
+
+(define (colorize-matches rules)
+  "Return a procedure that, when passed a string, returns that string
+colorized according to RULES.  RULES must be a list of tuples like:
+
+  (REGEXP COLOR1 COLOR2 ...)
+
+where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
+on."
+  (lambda (str)
+    (if (string-index str #\nul)
+        str
+        (let loop ((rules rules))
+          (match rules
+            (()
+             str)
+            (((regexp . colors) . rest)
+             (match (regexp-exec regexp str)
+               (#f (loop rest))
+               (m  (let loop ((n 1)
+                              (colors colors)
+                              (result (list (match:prefix m))))
+                     (match colors
+                       (()
+                        (string-concatenate-reverse
+                         (cons (match:suffix m) result)))
+                       ((first . tail)
+                        (loop (+ n 1)
+                              tail
+                              (cons (colorize-string (match:substring m n)
+                                                     first)
+                                    result)))))))))))))
+
+(define-syntax color-rules
+  (syntax-rules ()
+    "Return a procedure that colorizes the string it is passed according to
+the given rules.  Each rule has the form:
+
+  (REGEXP COLOR1 COLOR2 ...)
+
+where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
+on."
+    ((_ (regexp colors ...) ...)
+     (colorize-matches `((,(make-regexp regexp) ,(color colors) ...)
+                         ...)))))
diff --git a/guix/derivations.scm b/guix/derivations.scm
index fb2fa177be..7a5c3bca94 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -344,7 +344,8 @@ OUTPUTS of DRV and not already available in STORE, recursively, and the list
 of required store paths that can be substituted.  SUBSTITUTABLE-INFO must be a
 one-argument procedure similar to that returned by 'substitution-oracle'."
   (define built?
-    (cut valid-path? store <>))
+    (mlambda (item)
+      (valid-path? store item)))
 
   (define input-built?
     (compose (cut any built? <>) derivation-input-output-paths))
diff --git a/guix/download.scm b/guix/download.scm
index 8865777818..11984cf671 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2014, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
@@ -415,11 +415,7 @@
               (object->string %content-addressed-mirrors)))
 
 (define built-in-builders*
-  (let ((proc (store-lift built-in-builders)))
-    (lambda ()
-      "Return, as a monadic value, the list of built-in builders supported by
-the daemon; cache the return value."
-      (mcached (proc) built-in-builders))))
+  (store-lift built-in-builders))
 
 (define* (built-in-download file-name url
                             #:key system hash-algo hash
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 36028a01d6..5dcc0e97a3 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -58,7 +58,12 @@
 (define-peg-pattern weird-record all (and key (* SP) dict))
 (define-peg-pattern key body (+ (or (range #\a #\z) "-")))
 (define-peg-pattern value body (and (or conditional-value ground-value operator) (* SP)))
-(define-peg-pattern ground-value body (and (or multiline-string string-pat list-pat var) (* SP)))
+(define-peg-pattern choice-pat all (and (ignore "(") (* SP) choice (* SP)  (ignore ")")))
+(define-peg-pattern choice body
+  (or (and (or conditional-value ground-value) (* SP) (ignore "|") (* SP) choice)
+      conditional-value
+      ground-value))
+(define-peg-pattern ground-value body (and (or multiline-string string-pat choice-pat list-pat var) (* SP)))
 (define-peg-pattern conditional-value all (and ground-value (* SP) condition))
 (define-peg-pattern string-pat all (and QUOTE (* STRCHR) QUOTE))
 (define-peg-pattern list-pat all (and (ignore "[") (* SP) (* (and value (* SP))) (ignore "]")))
@@ -80,7 +85,8 @@
 (define-peg-pattern condition-form2 body
                     (and (* SP) (or condition-greater-or-equal condition-greater
                                     condition-lower-or-equal condition-lower
-                                    condition-neq condition-eq condition-content) (* SP)))
+                                    condition-neq condition-eq condition-not
+                                    condition-content) (* SP)))
 
 ;(define-peg-pattern condition-operator all (and (ignore operator) (* SP) condition-string))
 (define-peg-pattern condition-greater-or-equal all (and (ignore (and ">" "=")) (* SP) condition-string))
@@ -91,10 +97,12 @@
 (define-peg-pattern condition-or all (and condition-form2 (* SP) (ignore "|") (* SP) condition-form))
 (define-peg-pattern condition-eq all (and (? condition-content) (* SP) (ignore "=") (* SP) condition-content))
 (define-peg-pattern condition-neq all (and (? condition-content) (* SP) (ignore (and "!" "=")) (* SP) condition-content))
-(define-peg-pattern condition-content body (or condition-string condition-var))
+(define-peg-pattern condition-not all (and (ignore (and "!")) (* SP) condition-content))
+(define-peg-pattern condition-content body (or condition-paren condition-string condition-var))
 (define-peg-pattern condition-content2 body (and condition-content (* SP) (not-followed-by (or "&" "=" "!"))))
+(define-peg-pattern condition-paren body (and "(" condition-form ")"))
 (define-peg-pattern condition-string all (and QUOTE (* STRCHR) QUOTE))
-(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-")))
+(define-peg-pattern condition-var all (+ (or (range #\a #\z) "-" ":")))
 
 (define (get-opam-repository)
   "Update or fetch the latest version of the opam repository and return the
@@ -171,18 +179,24 @@ path to the repository."
 (define (dependency->input dependency)
   (match dependency
     (('string-pat str) str)
+    ;; Arbitrary select the first dependency
+    (('choice-pat choice ...) (dependency->input (car choice)))
     (('conditional-value val condition)
      (if (native? condition) "" (dependency->input val)))))
 
 (define (dependency->native-input dependency)
   (match dependency
     (('string-pat str) "")
+    ;; Arbitrary select the first dependency
+    (('choice-pat choice ...) (dependency->input (car choice)))
     (('conditional-value val condition)
      (if (native? condition) (dependency->input val) ""))))
 
 (define (dependency->name dependency)
   (match dependency
     (('string-pat str) str)
+    ;; Arbitrary select the first dependency
+    (('choice-pat choice ...) (dependency->input (car choice)))
     (('conditional-value val condition)
      (dependency->name val))))
 
@@ -233,39 +247,55 @@ path to the repository."
              (url-dict (metadata-ref opam-content "url"))
              (source-url (metadata-ref url-dict "src"))
              (requirements (metadata-ref opam-content "depends"))
-             (dependencies (dependency-list->names requirements))
+             (dependencies (filter
+                              (lambda (name)
+                                (not (member name '("dune" "jbuilder"))))
+                              (dependency-list->names requirements)))
+             (native-dependencies (depends->native-inputs requirements))
              (inputs (dependency-list->inputs (depends->inputs requirements)))
-             (native-inputs (dependency-list->inputs (depends->native-inputs requirements))))
-        (call-with-temporary-output-file
-          (lambda (temp port)
-            (and (url-fetch source-url temp)
-                 (values
-                  `(package
-                     (name ,(ocaml-name->guix-name name))
-                     (version ,(if (string-prefix? "v" version)
-                                 (substring version 1)
-                                 version))
-                     (source
-                       (origin
-                         (method url-fetch)
-                         (uri ,source-url)
-                         (sha256 (base32 ,(guix-hash-url temp)))))
-                     (build-system ocaml-build-system)
-                     ,@(if (null? inputs)
-                         '()
-                         `((inputs ,(list 'quasiquote inputs))))
-                     ,@(if (null? native-inputs)
-                         '()
-                         `((native-inputs ,(list 'quasiquote native-inputs))))
-                     ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
-                         '()
-                         `((properties
-                             ,(list 'quasiquote `((upstream-name . ,name))))))
-                     (home-page ,(metadata-ref opam-content "homepage"))
-                     (synopsis ,(metadata-ref opam-content "synopsis"))
-                     (description ,(metadata-ref opam-content "description"))
-                     (license #f))
-                  dependencies))))))
+             (native-inputs (dependency-list->inputs
+                              ;; Do not add dune nor jbuilder since they are
+                              ;; implicit inputs of the dune-build-system.
+                              (filter
+                                (lambda (name)
+                                  (not (member name '("dune" "jbuilder"))))
+                                native-dependencies))))
+        ;; If one of these are required at build time, it means we
+        ;; can use the much nicer dune-build-system.
+        (let ((use-dune? (or (member "dune" native-dependencies)
+                        (member "jbuilder" native-dependencies))))
+          (call-with-temporary-output-file
+            (lambda (temp port)
+              (and (url-fetch source-url temp)
+                   (values
+                    `(package
+                       (name ,(ocaml-name->guix-name name))
+                       (version ,(if (string-prefix? "v" version)
+                                   (substring version 1)
+                                   version))
+                       (source
+                         (origin
+                           (method url-fetch)
+                           (uri ,source-url)
+                           (sha256 (base32 ,(guix-hash-url temp)))))
+                       (build-system ,(if use-dune?
+                                          'dune-build-system
+                                          'ocaml-build-system))
+                       ,@(if (null? inputs)
+                           '()
+                           `((inputs ,(list 'quasiquote inputs))))
+                       ,@(if (null? native-inputs)
+                           '()
+                           `((native-inputs ,(list 'quasiquote native-inputs))))
+                       ,@(if (equal? name (guix-name->opam-name (ocaml-name->guix-name name)))
+                           '()
+                           `((properties
+                               ,(list 'quasiquote `((upstream-name . ,name))))))
+                       (home-page ,(metadata-ref opam-content "homepage"))
+                       (synopsis ,(metadata-ref opam-content "synopsis"))
+                       (description ,(metadata-ref opam-content "description"))
+                       (license #f))
+                    dependencies)))))))
 
 (define (opam-recursive-import package-name)
   (recursive-import package-name #f
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 6564526aee..dfc9ba1ca0 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -118,6 +118,7 @@
             profile-search-paths
 
             generation-number
+            generation-profile
             generation-numbers
             profile-generations
             relative-generation-spec->number
@@ -1552,6 +1553,20 @@ already effective."
              (compose string->number (cut match:substring <> 1)))
       0))
 
+(define %profile-generation-rx
+  ;; Regexp that matches profile generation.
+  (make-regexp "(.*)-([0-9]+)-link$"))
+
+(define (generation-profile file)
+  "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
+return its corresponding profile---e.g., \"guix-profile\".  Otherwise return
+#f."
+  (match (regexp-exec %profile-generation-rx file)
+    (#f #f)
+    (m  (let ((profile (match:substring m 1)))
+          (and (file-exists? (string-append profile "/manifest"))
+               profile)))))
+
 (define (generation-numbers profile)
   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
 former profiles were found."
diff --git a/guix/scripts.scm b/guix/scripts.scm
index e4b11d295d..77cbf12350 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -201,16 +201,12 @@ available."
     (when (< ratio threshold)
       (warning (G_ "only ~,1f% of free space available on ~a~%")
                (* ratio 100) (%store-prefix))
-      (if profile
-          (display-hint (format #f (G_ "Consider deleting old profile
+      (display-hint (format #f (G_ "Consider deleting old profile
 generations and collecting garbage, along these lines:
 
 @example
-guix package -p ~s --delete-generations=1m
-guix gc
+guix gc --delete-generations=1m
 @end example\n")
-                                profile))
-          (display-hint (G_ "Consider running @command{guix gc} to free
-space."))))))
+                            profile)))))
 
 ;;; scripts.scm ends here
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 28864435df..fc0c0e2ad3 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -119,7 +119,7 @@ found.  Return #f if no build log was found."
   (let* ((root (if (string-prefix? "/" root)
                    root
                    (string-append (canonicalize-path (dirname root))
-                                  "/" root))))
+                                  "/" (basename root)))))
     (catch 'system-error
       (lambda ()
         (match paths
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 6f37b767ff..9a57e5fd1e 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +20,10 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix store)
+  #:use-module (guix store roots)
   #:autoload   (guix build syscalls) (free-disk-space)
+  #:autoload   (guix profiles) (generation-profile)
+  #:autoload   (guix scripts package) (delete-generations)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -47,7 +50,12 @@ Invoke the garbage collector.\n"))
   (display (G_ "
   -F, --free-space=FREE  attempt to reach FREE available space in the store"))
   (display (G_ "
-  -d, --delete           attempt to delete PATHS"))
+  -d, --delete-generations[=PATTERN]
+                         delete profile generations matching PATTERN"))
+  (display (G_ "
+  -D, --delete           attempt to delete PATHS"))
+  (display (G_ "
+      --list-roots       list the user's garbage collector roots"))
   (display (G_ "
       --optimize         optimize the store by deduplicating identical files"))
   (display (G_ "
@@ -95,6 +103,16 @@ Invoke the garbage collector.\n"))
             lst)
           '()))))
 
+(define (delete-old-generations store profile pattern)
+  "Remove the generations of PROFILE that match PATTERN, a duration pattern.
+Do nothing if none matches."
+  (let* ((current (generation-number profile))
+         (numbers (matching-generations pattern profile
+                                        #:duration-relation >)))
+
+    ;; Make sure we don't inadvertently remove the current generation.
+    (delete-generations store profile (delv current numbers))))
+
 (define %options
   ;; Specification of the command-line options.
   (list (option '(#\h "help") #f #f
@@ -120,10 +138,25 @@ Invoke the garbage collector.\n"))
         (option '(#\F "free-space") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'free-space (size->number arg) result)))
-        (option '(#\d "delete") #f #f
+        (option '(#\D "delete") #f #f            ;used to be '-d' (lower case)
                 (lambda (opt name arg result)
                   (alist-cons 'action 'delete
                               (alist-delete 'action result))))
+        (option '(#\d "delete-generations") #f #t
+                (lambda (opt name arg result)
+                  (if (and arg (store-path? arg))
+                      (begin
+                        (warning (G_ "'-d' as an alias for '--delete' \
+is deprecated; use '-D'~%"))
+                        `((action . delete)
+                          (argument . ,arg)
+                          (alist-delete 'action result)))
+                      (begin
+                        (when (and arg (not (string->duration arg)))
+                          (leave (G_ "~s does not denote a duration~%")
+                                 arg))
+                        (alist-cons 'delete-generations (or arg "")
+                                    result)))))
         (option '("optimize") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'optimize
@@ -135,6 +168,10 @@ Invoke the garbage collector.\n"))
                                 (alist-cons 'verify-options options
                                             (alist-delete 'action
                                                           result))))))
+        (option '("list-roots") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'action 'list-roots
+                              (alist-delete 'action result))))
         (option '("list-dead") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'action 'list-dead
@@ -205,6 +242,27 @@ Invoke the garbage collector.\n"))
             (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
             (collect-garbage store to-free)))))
 
+  (define (delete-generations store pattern)
+    ;; Delete the generations matching PATTERN of all the user's profiles.
+    (let ((profiles (delete-duplicates
+                     (filter-map (lambda (root)
+                                   (and (or (zero? (getuid))
+                                            (user-owned? root))
+                                        (generation-profile root)))
+                                 (gc-roots)))))
+      (for-each (lambda (profile)
+                  (delete-old-generations store profile pattern))
+                profiles)))
+
+  (define (list-roots)
+    ;; List all the user-owned GC roots.
+    (let ((roots (filter (if (zero? (getuid)) (const #t) user-owned?)
+                         (gc-roots))))
+      (for-each (lambda (root)
+                  (display root)
+                  (newline))
+                roots)))
+
   (with-error-handling
     (let* ((opts  (parse-options))
            (store (open-connection))
@@ -229,6 +287,10 @@ Invoke the garbage collector.\n"))
          (assert-no-extra-arguments)
          (let ((min-freed  (assoc-ref opts 'min-freed))
                (free-space (assoc-ref opts 'free-space)))
+           (match (assoc-ref opts 'delete-generations)
+             (#f #t)
+             ((? string? pattern)
+              (delete-generations store pattern)))
            (cond
             (free-space
              (ensure-free-space store free-space))
@@ -238,6 +300,9 @@ Invoke the garbage collector.\n"))
             (else
              (let-values (((paths freed) (collect-garbage store)))
               (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
+        ((list-roots)
+         (assert-no-extra-arguments)
+         (list-roots))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index b0c6a7ced7..564236988e 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -278,11 +278,19 @@ path definition to be returned."
                 (evaluate-search-paths search-paths profiles
                                        getenv))))
 
+(define (absolutize file)
+  "Return an absolute file name equivalent to FILE, but without resolving
+symlinks like 'canonicalize-path' would do."
+  (if (string-prefix? "/" file)
+      file
+      (string-append (getcwd) "/" file)))
+
 (define* (display-search-paths entries profiles
                                #:key (kind 'exact))
   "Display the search path environment variables that may need to be set for
 ENTRIES, a list of manifest entries, in the context of PROFILE."
-  (let* ((profiles (map user-friendly-profile profiles))
+  (let* ((profiles (map (compose user-friendly-profile absolutize)
+                        profiles))
          (settings (search-path-environment-variables entries profiles
                                                       #:kind kind)))
     (unless (null? settings)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 2aaf1cc44a..55137fce8f 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -91,8 +91,6 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
   -p, --profile=PROFILE  use PROFILE instead of ~/.config/guix/current"))
   (display (G_ "
-  -n, --dry-run          show what would be pulled and built"))
-  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (G_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
diff --git a/guix/status.scm b/guix/status.scm
index bddaa003db..cbea4151f2 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -20,7 +20,7 @@
 (define-module (guix status)
   #:use-module (guix records)
   #:use-module (guix i18n)
-  #:use-module ((guix ui) #:select (colorize-string))
+  #:use-module (guix colors)
   #:use-module (guix progress)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module ((guix build download)
@@ -339,10 +339,6 @@ build-log\" traces."
   (and (current-store-protocol-version)
        (>= (current-store-protocol-version) #x163)))
 
-(define isatty?*
-  (mlambdaq (port)
-    (isatty? port)))
-
 (define spin!
   (let ((steps (circular-list "\\" "|" "/" "-")))
     (lambda (phase port)
@@ -362,44 +358,6 @@ the current build phase."
              (format port (G_ "'~a' phase") phase))
            (force-output port)))))))
 
-(define (color-output? port)
-  "Return true if we should write colored output to PORT."
-  (and (not (getenv "INSIDE_EMACS"))
-       (not (getenv "NO_COLOR"))
-       (isatty?* port)))
-
-(define-syntax color-rules
-  (syntax-rules ()
-    "Return a procedure that colorizes the string it is passed according to
-the given rules.  Each rule has the form:
-
-  (REGEXP COLOR1 COLOR2 ...)
-
-where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
-on."
-    ((_ (regexp colors ...) rest ...)
-     (let ((next (color-rules rest ...))
-           (rx   (make-regexp regexp)))
-       (lambda (str)
-         (if (string-index str #\nul)
-             str
-             (match (regexp-exec rx str)
-               (#f (next str))
-               (m  (let loop ((n 1)
-                              (c '(colors ...))
-                              (result '()))
-                     (match c
-                       (()
-                        (string-concatenate-reverse result))
-                       ((first . tail)
-                        (loop (+ n 1) tail
-                              (cons (colorize-string (match:substring m n)
-                                                     first)
-                                    result)))))))))))
-    ((_)
-     (lambda (str)
-       str))))
-
 (define colorize-log-line
   ;; Take a string and return a possibly colorized string according to the
   ;; rules below.
@@ -452,17 +410,17 @@ produce colorful output.  When PRINT-LOG? is true, display the build log in
 addition to build events."
   (define info
     (if colorize?
-        (cut colorize-string <> 'BOLD)
+        (cute colorize-string <> (color BOLD))
         identity))
 
   (define success
     (if colorize?
-        (cut colorize-string <> 'GREEN 'BOLD)
+        (cute colorize-string <> (color GREEN BOLD))
         identity))
 
   (define failure
     (if colorize?
-        (cut colorize-string <> 'RED 'BOLD)
+        (cute colorize-string <> (color RED BOLD))
         identity))
 
   (define (report-build-progress phase %)
diff --git a/guix/store.scm b/guix/store.scm
index 0a0a7c7c52..1b485ab5fa 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -368,7 +368,9 @@
   (ats-cache    store-connection-add-to-store-cache)
   (atts-cache   store-connection-add-text-to-store-cache)
   (object-cache store-connection-object-cache
-                (default vlist-null)))            ;vhash
+                (default vlist-null))             ;vhash
+  (built-in-builders store-connection-built-in-builders
+                     (default (delay '()))))      ;promise
 
 (set-record-type-printer! <store-connection>
                           (lambda (obj port)
@@ -557,13 +559,17 @@ for this connection will be pinned.  Return a server object."
                           (write-int cpu-affinity port)))
                       (when (>= (protocol-minor v) 11)
                         (write-int (if reserve-space? 1 0) port))
-                      (let ((conn (%make-store-connection port
-                                                          (protocol-major v)
-                                                          (protocol-minor v)
-                                                          output flush
-                                                          (make-hash-table 100)
-                                                          (make-hash-table 100)
-                                                          vlist-null)))
+                      (letrec* ((built-in-builders
+                                 (delay (%built-in-builders conn)))
+                                (conn
+                                 (%make-store-connection port
+                                                         (protocol-major v)
+                                                         (protocol-minor v)
+                                                         output flush
+                                                         (make-hash-table 100)
+                                                         (make-hash-table 100)
+                                                         vlist-null
+                                                         built-in-builders)))
                         (let loop ((done? (process-stderr conn)))
                           (or done? (process-stderr conn)))
                         conn)))))))))
@@ -578,13 +584,17 @@ already taken place on PORT and that we're just continuing on this established
 connection.  Use with care."
   (let-values (((output flush)
                 (buffering-output-port port (make-bytevector 8192))))
-    (%make-store-connection port
-                            (protocol-major version)
-                            (protocol-minor version)
-                            output flush
-                            (make-hash-table 100)
-                            (make-hash-table 100)
-                            vlist-null)))
+    (define connection
+      (%make-store-connection port
+                              (protocol-major version)
+                              (protocol-minor version)
+                              output flush
+                              (make-hash-table 100)
+                              (make-hash-table 100)
+                              vlist-null
+                              (delay (%built-in-builders connection))))
+
+    connection))
 
 (define (store-connection-version store)
   "Return the protocol version of STORE as an integer."
@@ -602,19 +612,23 @@ connection.  Use with care."
   "Close the connection to SERVER."
   (close (store-connection-socket server)))
 
-(define-syntax-rule (with-store store exp ...)
-  "Bind STORE to an open connection to the store and evaluate EXPs;
-automatically close the store when the dynamic extent of EXP is left."
+(define (call-with-store proc)
+  "Call PROC with an open store connection."
   (let ((store (open-connection)))
     (dynamic-wind
       (const #f)
       (lambda ()
         (parameterize ((current-store-protocol-version
                         (store-connection-version store)))
-         exp) ...)
+          (proc store)))
       (lambda ()
         (false-if-exception (close-connection store))))))
 
+(define-syntax-rule (with-store store exp ...)
+  "Bind STORE to an open connection to the store and evaluate EXPs;
+automatically close the store when the dynamic extent of EXP is left."
+  (call-with-store (lambda (store) exp ...)))
+
 (define current-store-protocol-version
   ;; Protocol version of the store currently used.  XXX: This is a hack to
   ;; communicate the protocol version to the build output port.  It's a hack
@@ -982,14 +996,52 @@ string).  Raise an error if no such path exists."
          (operation (add-text-to-store (string name) (bytevector text)
                                        (string-list references))
                     #f
-                    store-path)))
+                    store-path))
+        (lookup (if (profiled? "add-data-to-store-cache")
+                    (let ((lookups 0)
+                          (hits    0)
+                          (drv     0)
+                          (scheme  0))
+                      (define (show-stats)
+                        (define (% n)
+                          (if (zero? lookups)
+                              100.
+                              (* 100. (/ n lookups))))
+
+                        (format (current-error-port) "
+'add-data-to-store' cache:
+  lookups:      ~5@a
+  hits:         ~5@a (~,1f%)
+  .drv files:   ~5@a (~,1f%)
+  Scheme files: ~5@a (~,1f%)~%"
+                                lookups hits (% hits)
+                                drv (% drv)
+                                scheme (% scheme)))
+
+                      (register-profiling-hook! "add-data-to-store-cache"
+                                                show-stats)
+                      (lambda (cache args)
+                        (let ((result (hash-ref cache args)))
+                          (set! lookups (+ 1 lookups))
+                          (when result
+                            (set! hits (+ 1 hits)))
+                          (match args
+                            ((_ name _)
+                             (cond ((string-suffix? ".drv" name)
+                                    (set! drv (+ drv 1)))
+                                   ((string-suffix? "-builder" name)
+                                    (set! scheme (+ scheme 1)))
+                                   ((string-suffix? ".scm" name)
+                                    (set! scheme (+ scheme 1))))))
+                          result)))
+                    hash-ref)))
     (lambda* (server name bytes #:optional (references '()))
       "Add BYTES under file NAME in the store, and return its store path.
 REFERENCES is the list of store paths referred to by the resulting store
 path."
       (let* ((args  `(,bytes ,name ,references))
              (cache (store-connection-add-text-to-store-cache server)))
-        (or (hash-ref cache args)
+        (or (lookup cache args)
             (let ((path (add-text-to-store server name bytes references)))
               (hash-set! cache args path)
               path))))))
@@ -1367,13 +1419,13 @@ that there is no guarantee that the order of the resulting list matches the
 order of PATHS."
              substitutable-path-list))
 
-(define built-in-builders
+(define %built-in-builders
   (let ((builders (operation (built-in-builders)
                              "Return the built-in builders."
                              string-list)))
     (lambda (store)
       "Return the names of the supported built-in derivation builders
-supported by STORE."
+supported by STORE.  The result is memoized for STORE."
       ;; Check whether STORE's version supports this RPC and built-in
       ;; derivation builders in general, which appeared in Guix > 0.11.0.
       ;; Return the empty list if it doesn't.  Note that this RPC does not
@@ -1384,6 +1436,11 @@ supported by STORE."
           (builders store)
           '()))))
 
+(define (built-in-builders store)
+  "Return the names of the supported built-in derivation builders
+supported by STORE."
+  (force (store-connection-built-in-builders store)))
+
 (define-operation (optimize-store)
   "Optimize the store by hard-linking identical files (\"deduplication\".)
 Return #t on success."
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
new file mode 100644
index 0000000000..4f23ae34e8
--- /dev/null
+++ b/guix/store/roots.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 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 store roots)
+  #:use-module (guix config)
+  #:use-module ((guix store) #:select (store-path? %gc-roots-directory))
+  #:use-module (guix sets)
+  #:use-module (guix build syscalls)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:re-export (%gc-roots-directory)
+  #:export (gc-roots
+            user-owned?))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to list and access garbage collector roots ("GC
+;;; roots").
+;;;
+;;; Code:
+
+(define %profile-directory
+  ;; Directory where user profiles are stored.
+  ;; XXX: This is redundant with the definition in (guix profiles) and not
+  ;; entirely needed since in practice /var/guix/gcroots/profiles links to
+  ;; it.
+  (string-append %state-directory "/profiles"))
+
+(define (gc-roots)
+  "Return the list of garbage collector roots (\"GC roots\").  This includes
+\"regular\" roots fount in %GC-ROOTS-DIRECTORY as well as indirect roots that
+are user-controlled symlinks stored anywhere on the file system."
+  (define (regular? file)
+    (match file
+      (((or "." "..") . _) #f)
+      (_ #t)))
+
+  (define (file-type=? type)
+    (match-lambda
+      ((file . properties)
+       (match (assq-ref properties 'type)
+         ('unknown
+          (let ((stat (lstat file)))
+            (eq? type (stat:type stat))))
+         (actual-type
+          (eq? type actual-type))))))
+
+  (define directory?
+    (file-type=? 'directory))
+
+  (define symlink?
+    (file-type=? 'symlink))
+
+  (define canonical-root
+    (match-lambda
+      ((file . properties)
+       (let ((target (readlink file)))
+         (cond ((store-path? target)
+                ;; Regular root: FILE points to the store.
+                file)
+
+               ;; Indirect root: FILE points to a user-controlled file outside
+               ;; the store.
+               ((string-prefix? "/" target)
+                target)
+               (else
+                (string-append (dirname file) "/" target)))))))
+
+  (let loop ((directories (list %gc-roots-directory
+                                %profile-directory))
+             (roots       '())
+             (visited     (set)))
+    (match directories
+      (()
+       roots)
+      ((directory . rest)
+       (if (set-contains? visited directory)
+           (loop rest roots visited)
+           (let*-values (((scope)
+                          (cut string-append directory "/" <>))
+                         ((sub-directories files)
+                          (partition directory?
+                                     (map (match-lambda
+                                            ((file . properties)
+                                             (cons (scope file) properties)))
+                                          (scandir* directory regular?)))))
+             (loop (append rest (map first sub-directories))
+                   (append (map canonical-root (filter symlink? files))
+                           roots)
+                   (set-insert directory visited))))))))
+
+(define* (user-owned? root #:optional (uid (getuid)))
+  "Return true if ROOT exists and is owned by UID, false otherwise."
+  ;; If ROOT is an indirect root, then perhaps it no longer exists.  Thus,
+  ;; catch 'system-error' exceptions.
+  (catch 'system-error
+    (lambda ()
+      (define stat
+        (lstat root))
+
+      (= (stat:uid stat) uid))
+    (const #f)))
diff --git a/guix/ui.scm b/guix/ui.scm
index 0070301c47..92c845e944 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -10,8 +10,6 @@
 ;;; Copyright © 2016 Roel Janssen <roel@gnu.org>
 ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
-;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
-;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net>
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -31,6 +29,7 @@
 
 (define-module (guix ui)
   #:use-module (guix i18n)
+  #:use-module (guix colors)
   #:use-module (guix gexp)
   #:use-module (guix sets)
   #:use-module (guix utils)
@@ -118,8 +117,7 @@
             guix-warning-port
             warning
             info
-            guix-main
-            colorize-string))
+            guix-main))
 
 ;;; Commentary:
 ;;;
@@ -127,45 +125,124 @@
 ;;;
 ;;; Code:
 
-(define-syntax-rule (define-diagnostic name prefix)
-  "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
+(define-syntax highlight-argument
+  (lambda (s)
+    "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
+is a trivial format string."
+    (define (trivial-format-string? fmt)
+      (define len
+        (string-length fmt))
+
+      (let loop ((start 0))
+        (or (>= (+ 1 start) len)
+            (let ((tilde (string-index fmt #\~ start)))
+              (or (not tilde)
+                  (case (string-ref fmt (+ tilde 1))
+                    ((#\a #\A #\%) (loop (+ tilde 2)))
+                    (else          #f)))))))
+
+    ;; Be conservative: limit format argument highlighting to cases where the
+    ;; format string contains nothing but ~a escapes.  If it contained ~s
+    ;; escapes, this strategy wouldn't work.
+    (syntax-case s ()
+      ((_ "~a~%" arg)                          ;don't highlight whole messages
+       #'arg)
+      ((_ fmt arg)
+       (trivial-format-string? (syntax->datum #'fmt))
+       #'(%highlight-argument arg))
+      ((_ fmt arg)
+       #'arg))))
+
+(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
+  "Highlight ARG, a format string argument, if PORT supports colors."
+  (cond ((string? arg)
+         (highlight arg port))
+        ((symbol? arg)
+         (highlight (symbol->string arg) port))
+        (else arg)))
+
+(define-syntax define-diagnostic
+  (syntax-rules ()
+    "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
 messages."
-  (define-syntax name
-    (lambda (x)
-      (define (augmented-format-string fmt)
-        (string-append "~:[~*~;guix ~a: ~]~a" (syntax->datum fmt)))
-
-      (syntax-case x ()
-        ((name (underscore fmt) args (... ...))
-         (and (string? (syntax->datum #'fmt))
-              (free-identifier=? #'underscore #'G_))
-         (with-syntax ((fmt*   (augmented-format-string #'fmt))
-                       (prefix (datum->syntax x prefix)))
-           #'(format (guix-warning-port) (gettext fmt*)
-                     (program-name) (program-name) prefix
-                     args (... ...))))
-        ((name (N-underscore singular plural n) args (... ...))
-         (and (string? (syntax->datum #'singular))
-              (string? (syntax->datum #'plural))
-              (free-identifier=? #'N-underscore #'N_))
-         (with-syntax ((s      (augmented-format-string #'singular))
-                       (p      (augmented-format-string #'plural))
-                       (prefix (datum->syntax x prefix)))
-           #'(format (guix-warning-port)
-                     (ngettext s p n %gettext-domain)
-                     (program-name) (program-name) prefix
-                     args (... ...))))))))
-
-(define-diagnostic warning "warning: ") ; emit a warning
-(define-diagnostic info "")
-
-(define-diagnostic report-error "error: ")
+    ((_ name (G_ prefix) colors)
+     (define-syntax name
+       (lambda (x)
+         (syntax-case x ()
+           ((name location (underscore fmt) args (... ...))
+            (and (string? (syntax->datum #'fmt))
+                 (free-identifier=? #'underscore #'G_))
+            #'(begin
+                (print-diagnostic-prefix prefix location
+                                         #:colors colors)
+                (format (guix-warning-port) (gettext fmt %gettext-domain)
+                        (highlight-argument fmt args) (... ...))))
+           ((name location (N-underscore singular plural n)
+                  args (... ...))
+            (and (string? (syntax->datum #'singular))
+                 (string? (syntax->datum #'plural))
+                 (free-identifier=? #'N-underscore #'N_))
+            #'(begin
+                (print-diagnostic-prefix prefix location
+                                         #:colors colors)
+                (format (guix-warning-port)
+                        (ngettext singular plural n %gettext-domain)
+                        (highlight-argument singular args) (... ...))))
+           ((name (underscore fmt) args (... ...))
+            (free-identifier=? #'underscore #'G_)
+            #'(name #f (underscore fmt) args (... ...)))
+           ((name (N-underscore singular plural n)
+                  args (... ...))
+            (free-identifier=? #'N-underscore #'N_)
+            #'(name #f (N-underscore singular plural n)
+                    args (... ...)))))))))
+
+;; XXX: This doesn't work well for right-to-left languages.
+;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
+;; "~a" is a placeholder for that phrase.
+(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
+(define-diagnostic info (G_ "") %info-color)
+(define-diagnostic report-error (G_ "error: ") %error-color)
+
 (define-syntax-rule (leave args ...)
   "Emit an error message and exit."
   (begin
     (report-error args ...)
     (exit 1)))
 
+(define %warning-color (color BOLD MAGENTA))
+(define %info-color (color BOLD))
+(define %error-color (color BOLD RED))
+(define %hint-color (color BOLD CYAN))
+
+(define* (print-diagnostic-prefix prefix #:optional location
+                                  #:key (colors (color)))
+  "Print PREFIX as a diagnostic line prefix."
+  (define color?
+    (color-output? (guix-warning-port)))
+
+  (define location-color
+    (if color?
+        (cut colorize-string <> (color BOLD))
+        identity))
+
+  (define prefix-color
+    (if color?
+        (lambda (prefix)
+          (colorize-string prefix colors))
+        identity))
+
+  (let ((prefix (if (string-null? prefix)
+                    prefix
+                    (gettext prefix %gettext-domain))))
+    (if location
+        (format (guix-warning-port) "~a: ~a"
+                (location-color (location->string location))
+                (prefix-color prefix))
+        (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
+                (program-name) (program-name)
+                (prefix-color prefix)))))
+
 (define (print-unbound-variable-error port key args default-printer)
   ;; Print unbound variable errors more nicely, and in the right language.
   (match args
@@ -317,11 +394,18 @@ VARIABLE and return it, or #f if none was found."
 (define* (display-hint message #:optional (port (current-error-port)))
   "Display MESSAGE, a l10n message possibly containing Texinfo markup, to
 PORT."
-  (format port (G_ "hint: ~a~%")
-          ;; XXX: We should arrange so that the initial indent is wider.
-          (parameterize ((%text-width (max 15
-                                           (- (terminal-columns) 5))))
-            (texi->plain-text message))))
+  (define colorize
+    (if (color-output? port)
+        (lambda (str)
+          (colorize-string str %hint-color))
+        identity))
+
+  (display (colorize (G_ "hint: ")) port)
+  (display
+   ;; XXX: We should arrange so that the initial indent is wider.
+   (parameterize ((%text-width (max 15 (- (terminal-columns) 5))))
+     (texi->plain-text message))
+   port))
 
 (define* (report-unbound-variable-error args #:key frame)
   "Return the given unbound-variable error, where ARGS is the list of 'throw'
@@ -356,21 +440,15 @@ ARGS is the list of arguments received by the 'throw' handler."
          (apply throw args)))
     (('syntax-error proc message properties form . rest)
      (let ((loc (source-properties->location properties)))
-       (format (current-error-port) (G_ "~a: error: ~a~%")
-               (location->string loc) message)))
+       (report-error loc (G_ "~a~%") message)))
     (('unbound-variable _ ...)
      (report-unbound-variable-error args #:frame frame))
     (('srfi-34 obj)
      (if (message-condition? obj)
-         (if (error-location? obj)
-             (format (current-error-port)
-                     (G_ "~a: error: ~a~%")
-                     (location->string (error-location obj))
-                     (gettext (condition-message obj)
-                              %gettext-domain))
-             (report-error (G_ "~a~%")
-                           (gettext (condition-message obj)
-                                    %gettext-domain)))
+         (report-error (and (error-location? obj)
+                            (error-location obj))
+                       (G_ "~a~%")
+                       (gettext (condition-message obj) %gettext-domain))
          (report-error (G_ "exception thrown: ~s~%") obj))
      (when (fix-hint? obj)
        (display-hint (condition-fix-hint obj))))
@@ -394,8 +472,7 @@ exiting.  ARGS is the list of arguments received by the 'throw' handler."
        (warning (G_ "failed to load '~a': ~a~%") file (strerror err))))
     (('syntax-error proc message properties form . rest)
      (let ((loc (source-properties->location properties)))
-       (format (current-error-port) (G_ "~a: warning: ~a~%")
-               (location->string loc) message)))
+       (warning loc (G_ "~a~%") message)))
     (('srfi-34 obj)
      (if (message-condition? obj)
          (warning (G_ "failed to load '~a': ~a~%")
@@ -727,17 +804,14 @@ directories:~{ ~a~}~%")
                     (cons (invoke-error-program c)
                           (invoke-error-arguments c))))
             ((and (error-location? c) (message-condition? c))
-             (format (current-error-port)
-                     (G_ "~a: error: ~a~%")
-                     (location->string (error-location c))
-                     (gettext (condition-message c) %gettext-domain))
+             (report-error (error-location c) (G_ "~a~%")
+                           (gettext (condition-message c) %gettext-domain))
              (when (fix-hint? c)
                (display-hint (condition-fix-hint c)))
              (exit 1))
             ((and (message-condition? c) (fix-hint? c))
-             (format (current-error-port) "~a: error: ~a~%"
-                     (program-name)
-                     (gettext (condition-message c) %gettext-domain))
+             (report-error (G_ "~a~%")
+                           (gettext (condition-message c) %gettext-domain))
              (display-hint (condition-fix-hint c))
              (exit 1))
             ((message-condition? c)
@@ -1490,7 +1564,7 @@ DURATION-RELATION with the current time."
 (define (display-generation profile number)
   "Display a one-line summary of generation NUMBER of PROFILE."
   (unless (zero? number)
-    (let ((header (format #f (G_ "Generation ~a\t~a") number
+    (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number
                           (date->string
                            (time-utc->date
                             (generation-time profile number))
@@ -1703,54 +1777,4 @@ and signal handling has already been set up."
   (initialize-guix)
   (apply run-guix args))
 
-(define color-table
-  `((CLEAR       .   "0")
-    (RESET       .   "0")
-    (BOLD        .   "1")
-    (DARK        .   "2")
-    (UNDERLINE   .   "4")
-    (UNDERSCORE  .   "4")
-    (BLINK       .   "5")
-    (REVERSE     .   "6")
-    (CONCEALED   .   "8")
-    (BLACK       .  "30")
-    (RED         .  "31")
-    (GREEN       .  "32")
-    (YELLOW      .  "33")
-    (BLUE        .  "34")
-    (MAGENTA     .  "35")
-    (CYAN        .  "36")
-    (WHITE       .  "37")
-    (ON-BLACK    .  "40")
-    (ON-RED      .  "41")
-    (ON-GREEN    .  "42")
-    (ON-YELLOW   .  "43")
-    (ON-BLUE     .  "44")
-    (ON-MAGENTA  .  "45")
-    (ON-CYAN     .  "46")
-    (ON-WHITE    .  "47")))
-
-(define (color . lst)
-  "Return a string containing the ANSI escape sequence for producing the
-requested set of attributes in LST.  Unknown attributes are ignored."
-  (let ((color-list
-         (remove not
-                 (map (lambda (color) (assq-ref color-table color))
-                      lst))))
-    (if (null? color-list)
-        ""
-        (string-append
-         (string #\esc #\[)
-         (string-join color-list ";" 'infix)
-         "m"))))
-
-(define (colorize-string str . color-list)
-  "Return a copy of STR colorized using ANSI escape sequences according to the
-attributes STR.  At the end of the returned string, the color attributes will
-be reset such that subsequent output will not have any colors in effect."
-  (string-append
-   (apply color color-list)
-   str
-   (color 'RESET)))
-
 ;;; ui.scm ends here