Merge branch 'staging'

Conflicts:
	gnu/packages/admin.scm
	gnu/packages/commencement.scm
	gnu/packages/gdb.scm
	gnu/packages/llvm.scm
	gnu/packages/package-management.scm
	gnu/packages/tls.scm

12 files changed, 409 insertions, 145 deletions

diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index 0bac13edee..45f62f6ebc 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -31,6 +31,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 iconv)
   #:export (guix-authenticate))
 
 ;;; Commentary:
@@ -122,8 +123,9 @@ by colon, followed by the given number of characters."
                 (reverse result))
                (else
                 (let* ((len (string->number (read-delimited ":" port)))
-                       (str (utf8->string
-                             (get-bytevector-n port len))))
+                       (str (bytevector->string
+                             (get-bytevector-n port len)
+                             "ISO-8859-1" 'error)))
                   (loop (cons str result))))))))))
 
 (define-syntax define-enumerate-type              ;TODO: factorize
@@ -150,7 +152,7 @@ by colon, followed by the given number of characters."
 
   (define (send-reply code str)
     ;; Send CODE and STR as a reply to our client.
-    (let ((bv (string->utf8 str)))
+    (let ((bv (string->bytevector str "ISO-8859-1" 'error)))
       (format #t "~a ~a:" code (bytevector-length bv))
       (put-bytevector (current-output-port) bv)
       (force-output (current-output-port))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 25418661b9..e59e0ee67f 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -26,6 +26,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix memoization)
   #:use-module (guix grafts)
 
   #:use-module (guix utils)
@@ -38,6 +39,7 @@
   #:use-module (guix monads)
   #:use-module (guix gexp)
   #:use-module (guix profiles)
+  #:use-module (guix diagnostics)
   #:autoload   (guix http-client) (http-fetch http-get-error?)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -46,6 +48,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (gnu packages)
   #:autoload   (guix download) (download-to-store)
@@ -61,6 +64,7 @@
 
             %transformation-options
             options->transformation
+            manifest-entry-with-transformations
             show-transformation-options-help
 
             guix-build
@@ -393,6 +397,102 @@ a checkout of the Git repository at the given URL."
         (rewrite obj)
         obj)))
 
+(define (package-dependents/spec top bottom)
+  "Return the list of dependents of BOTTOM, a spec string, that are also
+dependencies of TOP, a package."
+  (define-values (name version)
+    (package-name->name+version bottom))
+
+  (define dependent?
+    (mlambda (p)
+      (and (package? p)
+           (or (and (string=? name (package-name p))
+                    (or (not version)
+                        (version-prefix? version (package-version p))))
+               (match (bag-direct-inputs (package->bag p))
+                 (((labels dependencies . _) ...)
+                  (any dependent? dependencies)))))))
+
+  (filter dependent? (package-closure (list top))))
+
+(define (package-toolchain-rewriting p bottom toolchain)
+  "Return a procedure that, when passed a package that's either BOTTOM or one
+of its dependents up to P so, changes it so it is built with TOOLCHAIN.
+TOOLCHAIN must be an input list."
+  (define rewriting-property
+    (gensym " package-toolchain-rewriting"))
+
+  (match (package-dependents/spec p bottom)
+    (()                                           ;P does not depend on BOTTOM
+     identity)
+    (set
+     ;; SET is the list of packages "between" P and BOTTOM (included) whose
+     ;; toolchain needs to be changed.
+     (package-mapping (lambda (p)
+                        (if (or (assq rewriting-property
+                                      (package-properties p))
+                                (not (memq p set)))
+                            p
+                            (let ((p (package-with-c-toolchain p toolchain)))
+                              (package/inherit p
+                                (properties `((,rewriting-property . #t)
+                                              ,@(package-properties p)))))))
+                      (lambda (p)
+                        (or (assq rewriting-property (package-properties p))
+                            (not (memq p set))))
+                      #:deep? #t))))
+
+(define (transform-package-toolchain replacement-specs)
+  "Return a procedure that, when passed a package, changes its toolchain or
+that of its dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is
+a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to
+the left of the equal sign must be built with the toolchain to the right of
+the equal sign."
+  (define split-on-commas
+    (cute string-tokenize <> (char-set-complement (char-set #\,))))
+
+  (define (specification->input spec)
+    (let ((package (specification->package spec)))
+      (list (package-name package) package)))
+
+  (define replacements
+    (map (lambda (spec)
+           (match (string-tokenize spec %not-equal)
+             ((spec (= split-on-commas toolchain))
+              (cons spec (map specification->input toolchain)))
+             (_
+              (leave (G_ "~a: invalid toolchain replacement specification~%")
+                     spec))))
+         replacement-specs))
+
+  (lambda (store obj)
+    (if (package? obj)
+        (or (any (match-lambda
+                   ((bottom . toolchain)
+                    ((package-toolchain-rewriting obj bottom toolchain) obj)))
+                 replacements)
+            obj)
+        obj)))
+
+(define (transform-package-tests specs)
+  "Return a procedure that, when passed a package, sets #:tests? #f in its
+'arguments' field."
+  (define (package-without-tests p)
+    (package/inherit p
+      (arguments
+       (substitute-keyword-arguments (package-arguments p)
+         ((#:tests? _ #f) #f)))))
+
+  (define rewrite
+    (package-input-rewriting/spec (map (lambda (spec)
+                                         (cons spec package-without-tests))
+                                       specs)))
+
+  (lambda (store obj)
+    (if (package? obj)
+        (rewrite obj)
+        obj)))
+
 (define %transformations
   ;; Transformations that can be applied to things to build.  The car is the
   ;; key used in the option alist, and the cdr is the transformation
@@ -403,7 +503,17 @@ a checkout of the Git repository at the given URL."
     (with-graft  . ,transform-package-inputs/graft)
     (with-branch . ,transform-package-source-branch)
     (with-commit . ,transform-package-source-commit)
-    (with-git-url . ,transform-package-source-git-url)))
+    (with-git-url . ,transform-package-source-git-url)
+    (with-c-toolchain . ,transform-package-toolchain)
+    (without-tests . ,transform-package-tests)))
+
+(define (transformation-procedure key)
+  "Return the transformation procedure associated with KEY, a symbol such as
+'with-source', or #f if there is none."
+  (any (match-lambda
+         ((k . proc)
+          (and (eq? k key) proc)))
+       %transformations))
 
 (define %transformation-options
   ;; The command-line interface to the above transformations.
@@ -423,11 +533,15 @@ a checkout of the Git repository at the given URL."
           (option '("with-commit") #t #f
                   (parser 'with-commit))
           (option '("with-git-url") #t #f
-                  (parser 'with-git-url)))))
+                  (parser 'with-git-url))
+          (option '("with-c-toolchain") #t #f
+                  (parser 'with-c-toolchain))
+          (option '("without-tests") #t #f
+                  (parser 'without-tests)))))
 
 (define (show-transformation-options-help)
   (display (G_ "
-      --with-source=SOURCE
+      --with-source=[PACKAGE=]SOURCE
                          use SOURCE when building the corresponding package"))
   (display (G_ "
       --with-input=PACKAGE=REPLACEMENT
@@ -443,7 +557,13 @@ a checkout of the Git repository at the given URL."
                          build PACKAGE from COMMIT"))
   (display (G_ "
       --with-git-url=PACKAGE=URL
-                         build PACKAGE from the repository at URL")))
+                         build PACKAGE from the repository at URL"))
+  (display (G_ "
+      --with-c-toolchain=PACKAGE=TOOLCHAIN
+                         build PACKAGE and its dependents with TOOLCHAIN"))
+  (display (G_ "
+      --without-tests=PACKAGE
+                         build PACKAGE without running its tests")))
 
 
 (define (options->transformation opts)
@@ -454,32 +574,69 @@ derivation, etc.), applies the transformations specified by OPTS."
     ;; order in which they appear on the command line.
     (filter-map (match-lambda
                   ((key . value)
-                   (match (any (match-lambda
-                                 ((k . proc)
-                                  (and (eq? k key) proc)))
-                               %transformations)
+                   (match (transformation-procedure key)
                      (#f
                       #f)
                      (transform
                       ;; XXX: We used to pass TRANSFORM a list of several
                       ;; arguments, but we now pass only one, assuming that
                       ;; transform composes well.
-                      (cons key (transform (list value)))))))
+                      (list key value (transform (list value)))))))
                 (reverse opts)))
 
+  (define (package-with-transformation-properties p)
+    (package/inherit p
+      (properties `((transformations
+                     . ,(map (match-lambda
+                               ((key value _)
+                                (cons key value)))
+                             applicable))
+                    ,@(package-properties p)))))
+
   (lambda (store obj)
-    (fold (match-lambda*
-            (((name . transform) obj)
-             (let ((new (transform store obj)))
-               (when (eq? new obj)
-                 (warning (G_ "transformation '~a' had no effect on ~a~%")
-                          name
-                          (if (package? obj)
-                              (package-full-name obj)
-                              obj)))
-               new)))
-          obj
-          applicable)))
+    (define (tagged-object new)
+      (if (and (not (eq? obj new))
+               (package? new) (not (null? applicable)))
+          (package-with-transformation-properties new)
+          new))
+
+    (tagged-object
+     (fold (match-lambda*
+             (((name value transform) obj)
+              (let ((new (transform store obj)))
+                (when (eq? new obj)
+                  (warning (G_ "transformation '~a' had no effect on ~a~%")
+                           name
+                           (if (package? obj)
+                               (package-full-name obj)
+                               obj)))
+                new)))
+           obj
+           applicable))))
+
+(define (package-transformations package)
+  "Return the transformations applied to PACKAGE according to its properties."
+  (match (assq-ref (package-properties package) 'transformations)
+    (#f '())
+    (transformations transformations)))
+
+(define (manifest-entry-with-transformations entry)
+  "Return ENTRY with an additional 'transformations' property if it's not
+already there."
+  (let ((properties (manifest-entry-properties entry)))
+    (if (assq 'transformations properties)
+        entry
+        (let ((item (manifest-entry-item entry)))
+          (manifest-entry
+            (inherit entry)
+            (properties
+             (match (and (package? item)
+                         (package-transformations item))
+               ((or #f '())
+                properties)
+               (transformations
+                `((transformations . ,transformations)
+                  ,@properties)))))))))
 
 
 ;;;
@@ -805,7 +962,28 @@ must be one of 'package', 'all', or 'transitive'~%")
 build---packages, gexps, derivations, and so on."
   (define (validate-type x)
     (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x))
-      (leave (G_ "~s: not something we can build~%") x)))
+      (raise (make-compound-condition
+               (formatted-message (G_ "~s: not something we can build~%") x)
+               (condition
+                (&fix-hint
+                 (hint
+                   (if (unspecified? x)
+                       (G_ "If you build from a file, make sure the last Scheme
+expression returns a package value.  @code{define-public} defines a variable,
+but returns @code{#<unspecified>}.  To fix this, add a Scheme expression at
+the end of the file that consists only of the package's variable name you
+defined, as in this example:
+
+@example
+(define-public my-package
+  (package
+    ...))
+
+my-package
+@end example")
+                       (G_ "If you build from a file, make sure the last
+Scheme expression returns a package, gexp, derivation or a list of such
+values.")))))))))
 
   (define (ensure-list x)
     (let ((lst (match x
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index ad50281eb2..085f11a9d4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -34,6 +34,7 @@
   #:use-module (guix scripts build)
   #:use-module (gnu build linux-container)
   #:use-module (gnu build accounts)
+  #:use-module ((guix build syscalls) #:select (set-network-interface-up))
   #:use-module (gnu system linux-container)
   #:use-module (gnu system file-systems)
   #:use-module (gnu packages)
@@ -549,6 +550,16 @@ WHILE-LIST."
             (write-passwd (list passwd))
             (write-group groups)
 
+            (unless network?
+              ;; When isolated from the network, provide a minimal /etc/hosts
+              ;; to resolve "localhost".
+              (call-with-output-file "/etc/hosts"
+                (lambda (port)
+                  (display "127.0.0.1 localhost\n" port)))
+
+              ;; Allow local AF_INET communications.
+              (set-network-interface-up "lo"))
+
             ;; For convenience, start in the user's current working
             ;; directory or, if unmapped, the home directory.
             (chdir (if map-cwd?
@@ -564,7 +575,11 @@ WHILE-LIST."
             (primitive-exit/status
              ;; A container's environment is already purified, so no need to
              ;; request it be purified again.
-             (launch-environment command profile manifest #:pure? #f)))
+             (launch-environment command
+                                 (if link-profile?
+                                     (string-append home-dir "/.guix-profile")
+                                     profile)
+                                 manifest #:pure? #f)))
           #:guest-uid uid
           #:guest-gid gid
           #:namespaces (if network?
diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm
index 710e786a79..906dca24b1 100644
--- a/guix/scripts/import/hackage.scm
+++ b/guix/scripts/import/hackage.scm
@@ -49,7 +49,7 @@
 Import and convert the Hackage package for PACKAGE-NAME.  If PACKAGE-NAME
 includes a suffix constituted by a at-sign followed by a numerical version (as
 used with Guix packages), then a definition for the specified version of the
-package will be generated.  If no version suffix is pecified, then the
+package will be generated.  If no version suffix is specified, then the
 generated package definition will correspond to the latest available
 version.\n"))
   (display (G_ "
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 3dc8ccefcb..a5fe98b675 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -88,6 +88,10 @@
                      (default 3))
   (daemon-socket   build-machine-daemon-socket    ; string
                    (default "/var/guix/daemon-socket/socket"))
+  ;; A #f value tells the offload scheduler to disregard the load of the build
+  ;; machine when selecting the best offload machine.
+  (overload-threshold build-machine-overload-threshold ; inexact real between
+                      (default 0.6))                   ; 0.0 and 1.0 | #f
   (parallel-builds build-machine-parallel-builds  ; number
                    (default 1))
   (speed           build-machine-speed            ; inexact real
@@ -391,30 +395,34 @@ of free disk space on '~a'~%")
   (* 100 (expt 2 20)))                            ;100 MiB
 
 (define (node-load node)
-  "Return the load on NODE.  Return +∞ if NODE is misbehaving."
+  "Return the load on NODE, a normalized value between 0.0 and 1.0.  The value
+is derived from /proc/loadavg and normalized according to the number of
+logical cores available, to give a rough estimation of CPU usage.  Return
+1.0 (fully loaded) if NODE is misbehaving."
   (let ((line (inferior-eval '(begin
                                 (use-modules (ice-9 rdelim))
                                 (call-with-input-file "/proc/loadavg"
                                   read-string))
-                             node)))
-    (if (eof-object? line)
-        +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
+                             node))
+        (ncores (inferior-eval '(begin
+                                  (use-modules (ice-9 threads))
+                                  (current-processor-count))
+                               node)))
+    (if (or (eof-object? line) (eof-object? ncores))
+        1.0    ;MACHINE does not respond, so assume it is fully loaded
         (match (string-tokenize line)
           ((one five fifteen . x)
-           (string->number one))
+           (let ((load (/ (string->number one) ncores)))
+             (if (> load 1.0)
+                 1.0
+                 load)))
           (x
-           +inf.0)))))
-
-(define (normalized-load machine load)
-  "Divide LOAD by the number of parallel builds of MACHINE."
-  (if (rational? load)
-      (let* ((jobs       (build-machine-parallel-builds machine))
-             (normalized (/ load jobs)))
-        (format (current-error-port) "load on machine '~a' is ~s\
- (normalized: ~s)~%"
-                (build-machine-name machine) load normalized)
-        normalized)
-      load))
+           1.0)))))
+
+(define (report-load machine load)
+  (format (current-error-port)
+          "normalized load on machine '~a' is ~,2f~%"
+          (build-machine-name machine) load))
 
 (define (random-seed)
   (logxor (getpid) (car (gettimeofday))))
@@ -472,11 +480,15 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
        (let* ((session (false-if-exception (open-ssh-session best
                                                              %short-timeout)))
               (node    (and session (remote-inferior session)))
-              (load    (and node (normalized-load best (node-load node))))
+              (load    (and node (node-load node)))
+              (threshold (build-machine-overload-threshold best))
               (space   (and node (node-free-disk-space node))))
+         (when load (report-load best load))
          (when node (close-inferior node))
          (when session (disconnect! session))
-         (if (and node (< load 2.) (>= space %minimum-disk-space))
+         (if (and node
+                  (or (not threshold) (< load threshold))
+                  (>= space %minimum-disk-space))
              (match others
                (((machines slots) ...)
                 ;; Release slots from the uninteresting machines.
@@ -708,13 +720,13 @@ machine."
                               (free (node-free-disk-space inferior)))
                           (close-inferior inferior)
                           (format #t "~a~%  kernel: ~a ~a~%  architecture: ~a~%\
-  host name: ~a~%  normalized load: ~a~%  free disk space: ~,2f MiB~%\
+  host name: ~a~%  normalized load: ~,2f~%  free disk space: ~,2f MiB~%\
   time difference: ~a s~%"
                                   (build-machine-name machine)
                                   (utsname:sysname uts) (utsname:release uts)
                                   (utsname:machine uts)
                                   (utsname:nodename uts)
-                                  (normalized-load machine load)
+                                  load
                                   (/ free (expt 2 20) 1.)
                                   (- time now))))))))
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a0112162e3..ea2a96d5a1 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -826,11 +826,17 @@ last resort for relocation."
 
                             (string-append "-DLOADER_AUDIT_MODULE=\""
                                            #$(audit-module) "\"")
+
+                            ;; XXX: Normally (runpath #$(audit-module)) is
+                            ;; enough.  However, to work around
+                            ;; <https://sourceware.org/bugzilla/show_bug.cgi?id=26634>
+                            ;; (glibc <= 2.32), pass the whole search path of
+                            ;; PROGRAM, which presumably is a superset of that
+                            ;; of the audit module.
                             (string-append "-DLOADER_AUDIT_RUNPATH={ "
                                            (string-join
                                             (map object->string
-                                                 (runpath
-                                                  #$(audit-module)))
+                                                 (runpath program))
                                             ", " 'suffix)
                                            "NULL }")
                             (if gconv
@@ -1143,19 +1149,24 @@ Create a bundle of PACKAGE.\n"))
                manifest))
             identity))
 
+      (define (with-transformations manifest)
+        (map-manifest-entries manifest-entry-with-transformations
+                              manifest))
+
       (with-provenance
-       (cond
-        ((and (not (null? manifests)) (not (null? packages)))
-         (leave (G_ "both a manifest and a package list were given~%")))
-        ((not (null? manifests))
-         (concatenate-manifests
-          (map (lambda (file)
-                 (let ((user-module (make-user-module
-                                     '((guix profiles) (gnu)))))
-                   (load* file user-module)))
-               manifests)))
-        (else
-         (packages->manifest packages))))))
+       (with-transformations
+        (cond
+         ((and (not (null? manifests)) (not (null? packages)))
+          (leave (G_ "both a manifest and a package list were given~%")))
+         ((not (null? manifests))
+          (concatenate-manifests
+           (map (lambda (file)
+                  (let ((user-module (make-user-module
+                                      '((guix profiles) (gnu)))))
+                    (load* file user-module)))
+                manifests)))
+         (else
+          (packages->manifest packages)))))))
 
   (with-error-handling
     (with-store store
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4eb968a49b..2f04652634 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -218,12 +218,13 @@ non-zero relevance score."
         (output (manifest-entry-output old)))
       transaction)))
 
-  (define (upgrade entry)
+  (define (upgrade entry transform)
     (match entry
       (($ <manifest-entry> name version output (? string? path))
        (match (find-best-packages-by-name name #f)
          ((pkg . rest)
-          (let ((candidate-version (package-version pkg)))
+          (let* ((pkg               (transform store pkg))
+                 (candidate-version (package-version pkg)))
             (match (package-superseded pkg)
               ((? package? new)
                (supersede entry new))
@@ -231,12 +232,14 @@ non-zero relevance score."
                (case (version-compare candidate-version version)
                  ((>)
                   (manifest-transaction-install-entry
-                   (package->manifest-entry* pkg output)
+                   (manifest-entry-with-transformations
+                    (package->manifest-entry* pkg output))
                    transaction))
                  ((<)
                   transaction)
                  ((=)
-                  (let* ((new (package->manifest-entry* pkg output)))
+                  (let* ((new (manifest-entry-with-transformations
+                               (package->manifest-entry* pkg output))))
                     ;; Here we want to determine whether the NEW actually
                     ;; differs from ENTRY, but we need to intercept
                     ;; 'build-things' calls because they would prevent us from
@@ -255,7 +258,14 @@ non-zero relevance score."
 
   (if (manifest-transaction-removal-candidate? entry transaction)
       transaction
-      (upgrade entry)))
+
+      ;; Upgrade ENTRY, preserving transformation options listed in its
+      ;; properties.
+      (let ((transform (options->transformation
+                        (or (assq-ref (manifest-entry-properties entry)
+                                      'transformations)
+                            '()))))
+        (upgrade entry transform))))
 
 
 ;;;
@@ -585,14 +595,8 @@ upgrading, #f otherwise."
 (define (package->manifest-entry* package output)
   "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to
 the resulting manifest entry."
-  (define (provenance-properties package)
-    (match (package-provenance package)
-      (#f   '())
-      (sexp `((provenance ,@sexp)))))
-
-  (package->manifest-entry package output
-                           #:properties (provenance-properties package)))
-
+  (manifest-entry-with-provenance
+   (package->manifest-entry package output)))
 
 (define (options->installable opts manifest transaction)
   "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
@@ -870,12 +874,13 @@ processed, #f otherwise."
 
   (define (transform-entry entry)
     (let ((item (transform store (manifest-entry-item entry))))
-      (manifest-entry
-        (inherit entry)
-        (item item)
-        (version (if (package? item)
-                     (package-version item)
-                     (manifest-entry-version entry))))))
+      (manifest-entry-with-transformations
+       (manifest-entry
+         (inherit entry)
+         (item item)
+         (version (if (package? item)
+                      (package-version item)
+                      (manifest-entry-version entry)))))))
 
   (when (equal? profile %current-profile)
     ;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm
index 3c79e89f8d..9f20803efc 100644
--- a/guix/scripts/repl.scm
+++ b/guix/scripts/repl.scm
@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
+  #:autoload   (guix describe) (current-profile)
   #:autoload   (system repl repl) (start-repl)
   #:autoload   (system repl server)
                   (make-tcp-server-socket make-unix-domain-server-socket)
@@ -176,9 +177,19 @@ call THUNK."
       ;; Run script
       (save-module-excursion
        (lambda ()
+         ;; Invoke 'current-profile' so that it memoizes the correct value
+         ;; based on (program-arguments), before we call
+         ;; 'set-program-arguments'.  This in turn ensures that
+         ;; (%package-module-path) will contain entries for the channels
+         ;; available in the current profile.
+         (current-profile)
+
          (set-program-arguments script)
          (set-user-module)
-         (load-in-vicinity "." (car script)))))
+
+         ;; When passed a relative file name, 'load-in-vicinity' searches the
+         ;; file in %LOAD-PATH.  Thus, pass (getcwd) instead of ".".
+         (load-in-vicinity (getcwd) (car script)))))
 
     (when (null? script)
       ;; Start REPL
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 26613df68f..7ec170b08a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -137,7 +137,7 @@ disabled!~%"))
 
 (define %narinfo-negative-ttl
   ;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
-  (* 3 3600))
+  (* 1 3600))
 
 (define %narinfo-transient-error-ttl
   ;; Likewise, but for transient errors such as 504 ("Gateway timeout").
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index bd5f84fc5b..9ed5c26483 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -384,6 +384,7 @@ STORE is an open connection to the store."
          ;; Make the specified system generation the default entry.
          (params (first (profile-boot-parameters %system-profile
                                                  (list number))))
+         (locale (boot-parameters-locale params))
          (old-generations
           (delv number (reverse (generation-numbers %system-profile))))
          (old-params (profile-boot-parameters
@@ -396,6 +397,7 @@ STORE is an open connection to the store."
           ((bootcfg (lower-object
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
+                      #:locale locale
                       #:old-entries old-entries)))
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
@@ -666,38 +668,45 @@ checking this by themselves in their 'check' procedure."
 ;;; Action.
 ;;;
 
-(define* (system-derivation-for-action os base-image action
-                                       #:key image-size file-system-type
+(define* (system-derivation-for-action os action
+                                       #:key image-size image-type
                                        full-boot? container-shared-network?
                                        mappings label)
   "Return as a monadic value the derivation for OS according to ACTION."
-  (case action
-    ((build init reconfigure)
-     (operating-system-derivation os))
-    ((container)
-     (container-script
-      os
-      #:mappings mappings
-      #:shared-network? container-shared-network?))
-    ((vm-image)
-     (system-qemu-image os #:disk-image-size image-size))
-    ((vm)
-     (system-qemu-image/shared-store-script os
-                                            #:full-boot? full-boot?
-                                            #:disk-image-size
-                                            (if full-boot?
-                                                image-size
-                                                (* 70 (expt 2 20)))
-                                            #:mappings mappings))
-    ((disk-image)
-     (lower-object
-      (system-image
-       (image
-        (inherit (if label (image-with-label base-image label) base-image))
-        (size image-size)
-        (operating-system os)))))
-    ((docker-image)
-     (system-docker-image os #:shared-network? container-shared-network?))))
+  (mlet %store-monad ((target (current-target-system)))
+    (case action
+      ((build init reconfigure)
+       (operating-system-derivation os))
+      ((container)
+       (container-script
+        os
+        #:mappings mappings
+        #:shared-network? container-shared-network?))
+      ((vm-image)
+       (system-qemu-image os #:disk-image-size image-size))
+      ((vm)
+       (system-qemu-image/shared-store-script os
+                                              #:full-boot? full-boot?
+                                              #:disk-image-size
+                                              (if full-boot?
+                                                  image-size
+                                                  (* 70 (expt 2 20)))
+                                              #:mappings mappings))
+      ((disk-image)
+       (let* ((base-image (os->image os #:type image-type))
+              (base-target (image-target base-image)))
+         (lower-object
+          (system-image
+           (image
+            (inherit (if label
+                         (image-with-label base-image label)
+                         base-image))
+            (target (or base-target target))
+            (size image-size)
+            (operating-system os))))))
+      ((docker-image)
+       (system-docker-image os
+                            #:shared-network? container-shared-network?)))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -748,18 +757,19 @@ and TARGET arguments."
                          install-bootloader?
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
-                         image-size file-system-type full-boot? label
-                         container-shared-network?
+                         image-size image-type
+                         full-boot? label container-shared-network?
                          (mappings '())
                          (gc-root #f))
   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
 bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
 target root directory; IMAGE-SIZE is the size of the image to be built, for
-the 'vm-image' and 'disk-image' actions.  The root file system is created as a
-FILE-SYSTEM-TYPE file system.  FULL-BOOT? is used for the 'vm' action; it
-determines whether to boot directly to the kernel or to the bootloader.
-CONTAINER-SHARED-NETWORK? determines if the container will use a separate
-network namespace.
+the 'vm-image' and 'disk-image' actions.  IMAGE-TYPE is the type of image to
+be built.
+
+FULL-BOOT? is used for the 'vm' action; it determines whether to
+boot directly to the kernel or to the bootloader.  CONTAINER-SHARED-NETWORK?
+determines if the container will use a separate network namespace.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything.
@@ -799,11 +809,9 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((target*   (current-target-system))
-       (image ->  (find-image file-system-type target*))
-       (sys       (system-derivation-for-action os image action
+      ((sys       (system-derivation-for-action os action
                                                 #:label label
-                                                #:file-system-type file-system-type
+                                                #:image-type image-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
                                                 #:container-shared-network? container-shared-network?
@@ -888,6 +896,17 @@ Run 'herd status' to view the list of services on your system.\n"))))))
 
 
 ;;;
+;;; Images.
+;;;
+
+(define (list-image-types)
+  "Print the available image types."
+  (display (G_ "The available image types are:\n"))
+  (newline)
+  (format #t "~{   - ~a ~%~}" (map image-type-name (force %image-types))))
+
+
+;;;
 ;;; Options.
 ;;;
 
@@ -945,9 +964,9 @@ Some ACTIONS support additional ARGS.\n"))
                          apply STRATEGY (one of nothing-special, backtrace,
                          or debug) when an error occurs while reading FILE"))
   (display (G_ "
-      --file-system-type=TYPE
-                         for 'disk-image', produce a root file system of TYPE
-                         (one of 'ext4', 'iso9660')"))
+      --list-image-types list available image types"))
+  (display (G_ "
+  -t, --image-type=TYPE  for 'disk-image', produce an image of TYPE"))
   (display (G_ "
       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
   (display (G_ "
@@ -1008,10 +1027,14 @@ Some ACTIONS support additional ARGS.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'on-error (string->symbol arg)
                                result)))
-         (option '(#\t "file-system-type") #t #f
+         (option '(#\t "image-type") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'file-system-type arg
+                   (alist-cons 'image-type (string->symbol arg)
                                result)))
+         (option '("list-image-types") #f #f
+                 (lambda (opt name arg result)
+                   (list-image-types)
+                   (exit 0)))
          (option '("image-size") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'image-size (size->number arg)
@@ -1080,7 +1103,7 @@ Some ACTIONS support additional ARGS.\n"))
     (debug . 0)
     (verbosity . #f)                              ;default
     (validate-reconfigure . ,ensure-forward-reconfigure)
-    (file-system-type . "ext4")
+    (image-type . raw)
     (image-size . guess)
     (install-bootloader? . #t)
     (label . #f)))
@@ -1177,7 +1200,8 @@ resulting from command-line parsing."
                                (assoc-ref opts 'skip-safety-checks?)
                                #:validate-reconfigure
                                (assoc-ref opts 'validate-reconfigure)
-                               #:file-system-type (assoc-ref opts 'file-system-type)
+                               #:image-type (lookup-image-type-by-name
+                                             (assoc-ref opts 'image-type))
                                #:image-size (assoc-ref opts 'image-size)
                                #:full-boot? (assoc-ref opts 'full-boot?)
                                #:container-shared-network?
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 45bb1d5d3b..d89caf80fc 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -126,22 +126,25 @@ return the <live-service> objects that are currently running on MACHINE."
   (define exp
     (with-imported-modules '((gnu services herd))
       #~(begin
-          (use-modules (gnu services herd))
+          (use-modules (gnu services herd)
+                       (ice-9 match))
+
           (let ((services (current-services)))
             (and services
-                 ;; 'live-service-running' is ignored, as we can't necessarily
-                 ;; serialize arbitrary objects. This should be fine for now,
-                 ;; since 'machine-current-services' is not exposed publicly,
-                 ;; and the resultant <live-service> objects are only used for
-                 ;; resolving service dependencies.
                  (map (lambda (service)
                         (list (live-service-provision service)
-                              (live-service-requirement service)))
+                              (live-service-requirement service)
+                              (match (live-service-running service)
+                                (#f #f)
+                                (#t #t)
+                                ((? number? pid) pid)
+                                (_ #t))))         ;not serializable
                       services))))))
+
   (mlet %store-monad ((services (eval exp)))
     (return (map (match-lambda
-                   ((provision requirement)
-                    (live-service provision requirement #f)))
+                   ((provision requirement running)
+                    (live-service provision requirement running)))
                  services))))
 
 ;; XXX: Currently, this does NOT attempt to restart running services. See
@@ -181,13 +184,14 @@ services as defined by OS."
   (mlet* %store-monad ((live-services (running-services eval)))
     (let*-values (((to-unload to-restart)
                    (shepherd-service-upgrade live-services target-services)))
-      (let* ((to-unload (map live-service-canonical-name to-unload))
+      (let* ((to-unload  (map live-service-canonical-name to-unload))
              (to-restart (map shepherd-service-canonical-name to-restart))
-             (to-start (lset-difference eqv?
-                                        (map shepherd-service-canonical-name
-                                             target-services)
-                                        (map live-service-canonical-name
-                                             live-services)))
+             (running    (map live-service-canonical-name
+                              (filter live-service-running live-services)))
+             (to-start   (lset-difference eqv?
+                                          (map shepherd-service-canonical-name
+                                               target-services)
+                                          running))
              (service-files (map shepherd-service-file target-services)))
         (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
                   (primitive-load #$(upgrade-services-program service-files
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index 8c7abd133a..5ec844328e 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -36,6 +36,8 @@ This is an alias for 'guix package -u'.\n"))
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
   (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
+  (display (G_ "
+      --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
   (newline)
   (show-build-options-help)
   (newline)