Merge branch 'master' into staging

16 files changed, 312 insertions, 91 deletions

diff --git a/guix/build-system.scm b/guix/build-system.scm
index 4174972b98..76d670995c 100644
--- a/guix/build-system.scm
+++ b/guix/build-system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,6 +18,7 @@
 
 (define-module (guix build-system)
   #:use-module (guix records)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (build-system
             build-system?
@@ -37,7 +38,9 @@
             bag-arguments
             bag-build
 
-            make-bag))
+            make-bag
+
+            build-system-with-c-toolchain))
 
 (define-record-type* <build-system> build-system make-build-system
   build-system?
@@ -98,3 +101,31 @@ intermediate representation just above derivations."
             #:outputs outputs
             #:target target
             arguments))))
+
+(define (build-system-with-c-toolchain bs toolchain)
+  "Return a variant of BS, a build system, that uses TOOLCHAIN instead of the
+default GNU C/C++ toolchain.  TOOLCHAIN must be a list of
+inputs (label/package tuples) providing equivalent functionality, such as the
+'gcc-toolchain' package."
+  (define lower
+    (build-system-lower bs))
+
+  (define toolchain-packages
+    ;; These are the GNU toolchain packages pulled in by GNU-BUILD-SYSTEM and
+    ;; all the build systems that inherit from it.  Keep the list in sync with
+    ;; 'standard-packages' in (guix build-system gnu).
+    '("gcc" "binutils" "libc" "libc:static" "ld-wrapper"))
+
+  (define (lower* . args)
+    (let ((lowered (apply lower args)))
+      (bag
+        (inherit lowered)
+        (build-inputs
+         (append (fold alist-delete
+                       (bag-build-inputs lowered)
+                       toolchain-packages)
+                 toolchain)))))
+
+  (build-system
+    (inherit bs)
+    (lower lower*)))
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 95e8dd772a..117c8da66c 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -173,7 +173,13 @@ directory = '" port)
     (or skip-build?
         (not (has-executable-target?))
         (invoke "cargo" "install" "--path" "." "--root" out
-                "--features" (string-join features)))))
+                "--features" (string-join features)))
+
+    ;; This is a file which we definitely don't need installed.
+    (when (file-exists? (string-append out "/.crates.toml"))
+      (delete-file (string-append out "/.crates.toml")))
+
+    #t))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
diff --git a/guix/build/hg.scm b/guix/build/hg.scm
index b3e3ff7ac3..0ffad7fa2d 100644
--- a/guix/build/hg.scm
+++ b/guix/build/hg.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +21,8 @@
 
 (define-module (guix build hg)
   #:use-module (guix build utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (ice-9 format)
   #:export (hg-fetch))
 
 ;;; Commentary:
@@ -35,22 +38,29 @@
   "Fetch CHANGESET from URL into DIRECTORY.  CHANGESET must be a valid
 Mercurial changeset identifier.  Return #t on success, #f otherwise."
 
-  (invoke hg-command
-          "clone" url
-          "--rev" changeset
-          ;; Disable TLS certificate verification.  The hash of
-          ;; the checkout is known in advance anyway.
-          "--insecure"
-          directory)
-
-  ;; The contents of '.hg' vary as a function of the current
-  ;; status of the Mercurial repo.  Since we want a fixed
-  ;; output, this directory needs to be taken out.
-  ;; Since the '.hg' file is also in sub-modules, we have to
-  ;; search for it in all sub-directories.
-  (for-each delete-file-recursively
-            (find-files directory "^\\.hg$" #:directories? #t))
-
-  #t)
+  (mkdir-p directory)
+
+  (guard (c ((invoke-error? c)
+             (report-invoke-error c)
+             (delete-file-recursively directory)
+             #f))
+    (with-directory-excursion directory
+      (invoke hg-command
+              "clone" url
+              "--rev" changeset
+              ;; Disable TLS certificate verification.  The hash of
+              ;; the checkout is known in advance anyway.
+              "--insecure"
+              directory)
+
+      ;; The contents of '.hg' vary as a function of the current
+      ;; status of the Mercurial repo.  Since we want a fixed
+      ;; output, this directory needs to be taken out.
+      ;; Since the '.hg' file is also in sub-modules, we have to
+      ;; search for it in all sub-directories.
+      (for-each delete-file-recursively
+                (find-files directory "^\\.hg$" #:directories? #t))
+
+      #t)))
 
 ;;; hg.scm ends here
diff --git a/guix/build/svn.scm b/guix/build/svn.scm
index 33783f3056..44d77a968f 100644
--- a/guix/build/svn.scm
+++ b/guix/build/svn.scm
@@ -1,7 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,6 +21,8 @@
 
 (define-module (guix build svn)
   #:use-module (guix build utils)
+  #:use-module (srfi srfi-34)
+  #:use-module (ice-9 format)
   #:export (svn-fetch))
 
 ;;; Commentary:
@@ -36,20 +39,23 @@
                     (password #f))
   "Fetch REVISION from URL into DIRECTORY.  REVISION must be an integer, and a
 valid Subversion revision.  Return #t on success, #f otherwise."
-  (apply invoke svn-command
-         "export" "--non-interactive"
-         ;; Trust the server certificate.  This is OK as we
-         ;; verify the checksum later.  This can be removed when
-         ;; ca-certificates package is added.
-         "--trust-server-cert" "-r" (number->string revision)
-         `(,@(if (and user-name password)
-                 (list (string-append "--username=" user-name)
-                       (string-append "--password=" password))
-                 '())
-           ,@(if recursive?
-                 '()
-                 (list "--ignore-externals"))
-           ,url ,directory))
-  #t)
+  (guard (c ((invoke-error? c)
+             (report-invoke-error c)
+             #f))
+    (apply invoke svn-command
+           "export" "--non-interactive"
+           ;; Trust the server certificate.  This is OK as we
+           ;; verify the checksum later.  This can be removed when
+           ;; ca-certificates package is added.
+           "--trust-server-cert" "-r" (number->string revision)
+           `(,@(if (and user-name password)
+                   (list (string-append "--username=" user-name)
+                         (string-append "--password=" password))
+                   '())
+             ,@(if recursive?
+                   '()
+                   (list "--ignore-externals"))
+             ,url ,directory))
+    #t))
 
 ;;; svn.scm ends here
diff --git a/guix/channels.scm b/guix/channels.scm
index ad2442f50e..916d663e9f 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -783,7 +783,8 @@ modules in the old ~/.config/guix/latest style."
                    ;; derivation that builds modules.  We have to infer what the
                    ;; dependencies of these modules were.
                    (list guile-json-3 guile-git guile-bytestructures
-                         (ssh -> guile-ssh) (tls -> gnutls)))))
+                         (ssh -> guile-ssh) (tls -> gnutls))
+                   #:guile (default-guile))))
 
 (define (old-style-guix? drv)
   "Return true if DRV corresponds to a ~/.config/guix/latest style of
diff --git a/guix/cve.scm b/guix/cve.scm
index 57b8459d01..b3a8b13a06 100644
--- a/guix/cve.scm
+++ b/guix/cve.scm
@@ -336,7 +336,7 @@ sexp to CACHE."
                ,(map vulnerability->sexp vulns))
              cache))))
 
-(define (fetch-vulnerabilities year ttl)
+(define* (fetch-vulnerabilities year ttl #:key (timeout 10))
   "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has
 the given TTL (fetch from the NIST web site when TTL has expired)."
   (define (cache-miss uri)
@@ -361,16 +361,18 @@ the given TTL (fetch from the NIST web site when TTL has expired)."
   (let* ((port (http-fetch/cached (yearly-feed-uri year)
                                   #:ttl ttl
                                   #:write-cache write-cache
-                                  #:cache-miss cache-miss))
+                                  #:cache-miss cache-miss
+                                  #:timeout timeout))
          (sexp (read* port)))
     (close-port port)
     (match sexp
       (('vulnerabilities 1 vulns)
        (map sexp->vulnerability vulns)))))
 
-(define (current-vulnerabilities)
+(define* (current-vulnerabilities #:key (timeout 10))
   "Return the current list of Common Vulnerabilities and Exposures (CVE) as
-published by the US NIST."
+published by the US NIST.  TIMEOUT specifies the timeout in seconds for
+connection establishment."
   (let ((past-years (unfold (cut > <> 3)
                             (lambda (n)
                               (- %current-year n))
@@ -381,7 +383,7 @@ published by the US NIST."
                               (* n %past-year-ttl))
                             1+
                             1)))
-    (append-map fetch-vulnerabilities
+    (append-map (cut fetch-vulnerabilities <> <> #:timeout timeout)
                 (cons %current-year past-years)
                 (cons %current-year-ttl past-ttls))))
 
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 5a5a33b4c0..a767175d67 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -71,7 +71,8 @@
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
                      (verify-certificate? #t)
-                     (headers '((user-agent . "GNU Guile"))))
+                     (headers '((user-agent . "GNU Guile")))
+                     timeout)
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
@@ -80,13 +81,17 @@ extra HTTP headers.
 
 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
 
+TIMEOUT specifies the timeout in seconds for connection establishment; when
+TIMEOUT is #f, connection establishment never times out.
+
 Raise an '&http-get-error' condition if downloading fails."
   (let loop ((uri (if (string? uri)
                       (string->uri uri)
                       uri)))
     (let ((port (or port (guix:open-connection-for-uri uri
                                                        #:verify-certificate?
-                                                       verify-certificate?)))
+                                                       verify-certificate?
+                                                       #:timeout timeout)))
           (headers (match (uri-userinfo uri)
                      ((? string? str)
                       (cons (cons 'Authorization
@@ -155,13 +160,16 @@ Raise an '&http-get-error' condition if downloading fails."
 
 (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
                             (write-cache dump-port)
-                            (cache-miss (const #t)))
+                            (cache-miss (const #t))
+                            (timeout 10))
   "Like 'http-fetch', return an input port, but cache its contents in
 ~/.cache/guix.  The cache remains valid for TTL seconds.
 
 Call WRITE-CACHE with the HTTP input port and the cache output port to write
 the data to cache.  Call CACHE-MISS with URI just before fetching data from
-URI."
+URI.
+
+TIMEOUT specifies the timeout in seconds for connection establishment."
   (let ((file (cache-file-for-uri uri)))
     (define (update-cache cache-port)
       (define cache-time
@@ -183,7 +191,7 @@ URI."
                        cache-port)
                      (raise c))))
         (let ((port (http-fetch uri #:text? text?
-                                #:headers headers)))
+                                #:headers headers #:timeout timeout)))
           (cache-miss uri)
           (mkdir-p (dirname file))
           (when cache-port
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 5038f75638..cd43386102 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -76,7 +76,7 @@
             mpl1.0 mpl1.1 mpl2.0
             ms-pl
             ncsa
-            nmap
+            npsl
             ogl-psi1.0
             openldap2.8 openssl
             perl-license
@@ -521,10 +521,10 @@ at URI, which may be a file:// URI pointing the package's tree."
            "http://directory.fsf.org/wiki/License:IllinoisNCSA"
            "https://www.gnu.org/licenses/license-list#NCSA"))
 
-(define nmap
-  (license "Nmap license"
-           "https://svn.nmap.org/nmap/COPYING"
-           "https://fedoraproject.org/wiki/Licensing/Nmap"))
+(define npsl
+  (license "Nmap Public Source License"
+           "https://svn.nmap.org/nmap/LICENSE"
+           "https://nmap.org/npsl/"))
 
 (define ogl-psi1.0
   (license "Open Government Licence for Public Sector Information"
diff --git a/guix/lint.scm b/guix/lint.scm
index ec43a4dcad..e1a77e8ac7 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1084,7 +1084,7 @@ or HTTP errors.  This allows network-less operation and makes problems with
 the NIST server non-fatal."
   (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
                              '()
-                             (current-vulnerabilities)))
+                             (current-vulnerabilities #:timeout 4)))
 
 (define package-vulnerabilities
   (let ((lookup (delay (vulnerabilities->lookup-proc
diff --git a/guix/packages.scm b/guix/packages.scm
index 4f2bb432be..24d6417065 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -124,6 +124,7 @@
             package-patched-vulnerabilities
             package-with-patches
             package-with-extra-patches
+            package-with-c-toolchain
             package/inherit
 
             transitive-input-references
@@ -790,6 +791,14 @@ specifies modules in scope when evaluating SNIPPET."
                         (append (origin-patches (package-source original))
                                 patches)))
 
+(define (package-with-c-toolchain package toolchain)
+  "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
+C/C++ toolchain.  TOOLCHAIN must be a list of inputs (label/package tuples)
+providing equivalent functionality, such as the 'gcc-toolchain' package."
+  (let ((bs (package-build-system package)))
+    (package/inherit package
+      (build-system (build-system-with-c-toolchain bs toolchain)))))
+
 (define (transitive-inputs inputs)
   "Return the closure of INPUTS when considering the 'propagated-inputs'
 edges.  Omit duplicate inputs, except for those already present in INPUTS
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 72a5d46347..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)
@@ -396,6 +397,83 @@ 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."
@@ -426,6 +504,7 @@ a checkout of the Git repository at the given URL."
     (with-branch . ,transform-package-source-branch)
     (with-commit . ,transform-package-source-commit)
     (with-git-url . ,transform-package-source-git-url)
+    (with-c-toolchain . ,transform-package-toolchain)
     (without-tests . ,transform-package-tests)))
 
 (define (transformation-procedure key)
@@ -455,6 +534,8 @@ a checkout of the Git repository at the given URL."
                   (parser 'with-commit))
           (option '("with-git-url") #t #f
                   (parser 'with-git-url))
+          (option '("with-c-toolchain") #t #f
+                  (parser 'with-c-toolchain))
           (option '("without-tests") #t #f
                   (parser 'without-tests)))))
 
@@ -478,6 +559,9 @@ a checkout of the Git repository at the given URL."
       --with-git-url=PACKAGE=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")))
 
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/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/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)
diff --git a/guix/self.scm b/guix/self.scm
index 5eb80f42fe..bbfd2f1b95 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -27,6 +27,7 @@
   #:use-module (guix packages)
   #:use-module (guix sets)
   #:use-module (guix modules)
+  #:use-module ((guix utils) #:select (version-major+minor))
   #:use-module ((guix build utils) #:select (find-files))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -62,6 +63,7 @@
       ("xz"         (ref '(gnu packages compression) 'xz))
       ("po4a"       (ref '(gnu packages gettext) 'po4a))
       ("gettext"       (ref '(gnu packages gettext) 'gettext-minimal))
+      ("gcc-toolchain" (ref '(gnu packages commencement) 'gcc-toolchain))
       (_            #f))))                        ;no such package
 
 
@@ -580,6 +582,48 @@ that provide Guile modules."
 
   (computed-file name build))
 
+(define (quiet-guile guile)
+  "Return a wrapper that does the same as the 'guile' executable of GUILE,
+except that it does not complain about locales and falls back to 'en_US.utf8'
+instead of 'C'."
+  (define gcc
+    (specification->package "gcc-toolchain"))
+
+  (define source
+    (search-path %load-path
+                 "gnu/packages/aux-files/guile-launcher.c"))
+
+  (define effective
+    (version-major+minor (package-version guile)))
+
+  (define build
+    ;; XXX: Reuse <c-compiler> from (guix scripts pack) instead?
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (srfi srfi-26))
+
+          (mkdir-p (string-append #$output "/bin"))
+
+          (setenv "PATH" #$(file-append gcc "/bin"))
+          (setenv "C_INCLUDE_PATH"
+                  (string-join
+                   (map (cut string-append <> "/include")
+                        '#$(match (bag-transitive-build-inputs
+                                   (package->bag guile))
+                             (((labels packages . _) ...)
+                              (filter package? packages))))
+                   ":"))
+          (setenv "LIBRARY_PATH" #$(file-append gcc "/lib"))
+
+          (invoke "gcc" #$(local-file source) "-Wall" "-g0" "-O2"
+                  "-I" #$(file-append guile "/include/guile/" effective)
+                  "-L" #$(file-append guile "/lib")
+                  #$(string-append "-lguile-" effective)
+                  "-o" (string-append #$output "/bin/guile")))))
+
+  (computed-file "guile-wrapper" build))
+
 (define* (guix-command modules
                        #:key source (dependencies '())
                        guile (guile-version (effective-version)))
@@ -634,7 +678,9 @@ load path."
                       ;; XXX: It would be more convenient to change it to:
                       ;;   (exit (apply guix-main (command-line)))
                       (apply guix-main (command-line))))
-                #:guile guile))
+
+                ;; Use a 'guile' variant that doesn't complain about locales.
+                #:guile (quiet-guile guile)))
 
 (define (miscellaneous-files source)
   "Return data files taken from SOURCE."