summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-04-08 13:00:50 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-04-08 13:00:50 +0200
commit27783023993f9272ce422868d14529159c4a5218 (patch)
tree9013b08aa39e497b1fd8e01a05254278d83f0ff7 /guix
parentbe1e842ad78ac6c52fc7790f4a3ffd716673c111 (diff)
parentba6f2bda18ed19fa486a9c3e2c3baea6c66c6867 (diff)
downloadguix-patches-27783023993f9272ce422868d14529159c4a5218.tar
guix-patches-27783023993f9272ce422868d14529159c4a5218.tar.gz
Merge branch 'master' into core-updates
Conflicts: etc/news.scm gnu/local.mk gnu/packages/check.scm gnu/packages/cross-base.scm gnu/packages/gimp.scm gnu/packages/java.scm gnu/packages/mail.scm gnu/packages/sdl.scm gnu/packages/texinfo.scm gnu/packages/tls.scm gnu/packages/version-control.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build/bournish.scm24
-rw-r--r--guix/build/compile.scm51
-rw-r--r--guix/channels.scm19
-rw-r--r--guix/ci.scm4
-rw-r--r--guix/gexp.scm2
-rw-r--r--guix/git.scm9
-rw-r--r--guix/grafts.scm60
-rw-r--r--guix/lint.scm1
-rw-r--r--guix/packages.scm14
-rw-r--r--guix/profiles.scm80
-rw-r--r--guix/records.scm5
-rw-r--r--guix/scripts/pack.scm1
-rw-r--r--guix/scripts/package.scm76
-rw-r--r--guix/scripts/system.scm32
-rw-r--r--guix/scripts/system/reconfigure.scm63
-rw-r--r--guix/store.scm27
-rw-r--r--guix/ui.scm2
17 files changed, 282 insertions, 188 deletions
diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm
index 247a687d80..31fc493b09 100644
--- a/guix/build/bournish.scm
+++ b/guix/build/bournish.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -83,7 +83,21 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(newline)
(loop (map 1+ indexes)))))
-(define ls-command-implementation
+(define-syntax define-command-runtime
+ (syntax-rules ()
+ "Define run-time support of a Bournish command. This macro ensures that
+the implementation is not subject to inlining, which would prevent compiled
+code from referring to it via '@@'."
+ ((_ (command . args) body ...)
+ (define-command-runtime command (lambda args body ...)))
+ ((_ command exp)
+ (begin
+ (define command exp)
+
+ ;; Prevent inlining of COMMAND.
+ (set! command command)))))
+
+(define-command-runtime ls-command-implementation
;; Run-time support procedure.
(case-lambda
(()
@@ -173,13 +187,13 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(call-with-input-file file lines+chars)))
(format #t "~a ~a~%" chars file)))
-(define (wc-command-implementation . files)
+(define-command-runtime (wc-command-implementation . files)
(for-each wc-print (filter file-exists?* files)))
-(define (wc-l-command-implementation . files)
+(define-command-runtime (wc-l-command-implementation . files)
(for-each wc-l-print (filter file-exists?* files)))
-(define (wc-c-command-implementation . files)
+(define-command-runtime (wc-c-command-implementation . files)
(for-each wc-c-print (filter file-exists?* files)))
(define (wc-command . args)
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index 4b6472784c..3ce0ecede5 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -184,36 +184,35 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
;; Exit as soon as something goes wrong.
(exit-on-exception
file
- (with-target host
- (lambda ()
- (let ((relative (relative-file source-directory file)))
- (compile-file file
- #:output-file (string-append build-directory "/"
- (scm->go relative))
- #:opts (append warning-options
- (optimization-options relative))))))))
+ (let ((relative (relative-file source-directory file)))
+ (compile-file file
+ #:output-file (string-append build-directory "/"
+ (scm->go relative))
+ #:opts (append warning-options
+ (optimization-options relative))))))
(with-augmented-search-path %load-path source-directory
(with-augmented-search-path %load-compiled-path build-directory
(with-fluids ((*current-warning-prefix* ""))
-
- ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all
- ;; of FILES.
- (load-files source-directory files
- #:report-load report-load
- #:debug-port debug-port)
-
- ;; Make sure compilation related modules are loaded before starting to
- ;; compile files in parallel.
- (compile #f)
-
- ;; XXX: Don't use too many workers to work around the insane memory
- ;; requirements of the compiler in Guile 2.2.2:
- ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
- (n-par-for-each (min workers 8) build files)
-
- (unless (zero? total)
- (report-compilation #f total total))))))
+ (with-target host
+ (lambda ()
+ ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first
+ ;; load all of FILES.
+ (load-files source-directory files
+ #:report-load report-load
+ #:debug-port debug-port)
+
+ ;; Make sure compilation related modules are loaded before
+ ;; starting to compile files in parallel.
+ (compile #f)
+
+ ;; XXX: Don't use too many workers to work around the insane
+ ;; memory requirements of the compiler in Guile 2.2.2:
+ ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
+ (n-par-for-each (min workers 8) build files)
+
+ (unless (zero? total)
+ (report-compilation #f total total))))))))
(eval-when (eval load)
(when (and (string=? "2" (major-version))
diff --git a/guix/channels.scm b/guix/channels.scm
index f0261dc2da..785b97722e 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -349,6 +349,15 @@ to '%package-module-path'."
(((predicate . guile) rest ...)
(if (predicate source) (guile) (loop rest))))))
+(define (with-trivial-build-handler mvalue)
+ "Run MVALUE, a monadic value, with a \"trivial\" build handler installed
+that unconditionally resumes the continuation."
+ (lambda (store)
+ (with-build-handler (lambda (continue . _)
+ (continue #t))
+ (values (run-with-store store mvalue)
+ store))))
+
(define* (build-from-source name source
#:key core verbose? commit
(dependencies '()))
@@ -381,8 +390,14 @@ package modules under SOURCE using CORE, an instance of Guix."
(mbegin %store-monad
(mwhen guile
(set-guile-for-build guile))
- (build source #:verbose? verbose? #:version commit
- #:pull-version %pull-version)))
+
+ ;; BUILD is usually quite costly. Install a "trivial" build handler
+ ;; so we don't bounce an outer build-accumulator handler that could
+ ;; cause us to redo half of the BUILD computation several times just
+ ;; to realize it gives the same result.
+ (with-trivial-build-handler
+ (build source #:verbose? verbose? #:version commit
+ #:pull-version %pull-version))))
;; Build a set of modules that extend Guix using the standard method.
(standard-module-derivation name source core dependencies)))
diff --git a/guix/ci.scm b/guix/ci.scm
index 9e21996023..8fd05668f2 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -68,7 +68,7 @@
(define-json-mapping <evaluation> make-evaluation evaluation?
json->evaluation
(id evaluation-id) ;integer
- (spec evaluation-spec) ;string
+ (spec evaluation-spec "specification") ;string
(complete? evaluation-complete? "in-progress"
(match-lambda
(0 #t)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 1f1993a89f..2dea793685 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -730,7 +730,7 @@ names and file names suitable for the #:allowed-references argument to
#:target target)))
(return (derivation->output-path drv))))))
- (mapm %store-monad lower lst)))
+ (mapm/accumulate-builds lower lst)))
(define default-guile-derivation
;; Here we break the abstraction by talking to the higher-level layer.
diff --git a/guix/git.scm b/guix/git.scm
index b1ce3ea451..5fffd429bd 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -182,11 +182,10 @@ OID (roughly the commit hash) corresponding to REF."
(('tag . tag)
(let ((oid (reference-name->oid repository
(string-append "refs/tags/" tag))))
- ;; Get the commit that the tag at OID refers to. This is not
- ;; strictly needed, but it's more consistent to always return the
- ;; OID of a commit.
- (object-lookup repository
- (tag-target-id (tag-lookup repository oid))))))))
+ ;; OID may point to a "tag" object, but it can also point directly
+ ;; to a "commit" object, as surprising as it may seem. Return that
+ ;; object, whatever that is.
+ (object-lookup repository oid))))))
(reset repository obj RESET_HARD)
(object-id obj))
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 5173a77e58..69d6fe4469 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -152,43 +152,23 @@ are not recursively applied to dependencies of DRV."
#:properties properties)))))
-(define (non-self-references references drv outputs)
+(define (non-self-references store drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
-references. Call REFERENCES to get the list of references."
- (let ((refs (append-map (compose references
- (cut derivation->output-path drv <>))
- outputs))
- (self (match (derivation->output-paths drv)
- (((names . items) ...)
- items))))
- (remove (cut member <> self) refs)))
-
-(define (references-oracle store input)
- "Return a one-argument procedure that, when passed the output file names of
-INPUT, a derivation input, or their dependencies, returns the list of
-references of that item. Build INPUT if it's not available."
+references."
(define (references* items)
;; Return the references of ITEMS.
(guard (c ((store-protocol-error? c)
;; ITEMS are not in store so build INPUT first.
- (and (build-derivations store (list input))
- (map (cut references/cached store <>) items))))
- (map (cut references/cached store <>) items)))
+ (and (build-derivations store (list drv))
+ (append-map (cut references/cached store <>) items))))
+ (append-map (cut references/cached store <>) items)))
- (let loop ((items (derivation-input-output-paths input))
- (result vlist-null))
- (match items
- (()
- (lambda (item)
- (match (vhash-assoc item result)
- ((_ . refs) refs)
- (#f #f))))
- (_
- (let* ((refs (references* items))
- (result (fold vhash-cons result items refs)))
- (loop (remove (cut vhash-assoc <> result)
- (delete-duplicates (concatenate refs) string=?))
- result))))))
+ (let ((refs (references* (map (cut derivation->output-path drv <>)
+ outputs)))
+ (self (match (derivation->output-paths drv)
+ (((names . items) ...)
+ items))))
+ (remove (cut member <> self) refs)))
(define-syntax-rule (with-cache key exp ...)
"Cache the value of monadic expression EXP under KEY."
@@ -231,15 +211,12 @@ of DRV."
(set-insert drv visited)))))))))
(define* (cumulative-grafts store drv grafts
- references
#:key
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
(system (%current-system)))
"Augment GRAFTS with additional grafts resulting from the application of
-GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure
-that returns the list of references of the store item it is given. Return the
-resulting list of grafts.
+GRAFTS to the dependencies of DRV. Return the resulting list of grafts.
This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
derivations to the corresponding set of grafts."
@@ -262,7 +239,7 @@ derivations to the corresponding set of grafts."
;; If GRAFTS already contains a graft from DRV, do not override it.
(if (find (cut graft-origin? drv <>) grafts)
(state-return grafts)
- (cumulative-grafts store drv grafts references
+ (cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
#:system system)))
@@ -270,7 +247,7 @@ derivations to the corresponding set of grafts."
(state-return grafts))))
(with-cache (cons (derivation-file-name drv) outputs)
- (match (non-self-references references drv outputs)
+ (match (non-self-references store drv outputs)
(() ;no dependencies
(return grafts))
(deps ;one or more dependencies
@@ -307,15 +284,8 @@ derivations to the corresponding set of grafts."
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
DRV, and graft DRV itself to refer to those grafted dependencies."
-
- ;; First, pre-compute the dependency tree of the outputs of DRV. Do this
- ;; upfront to have as much parallelism as possible when querying substitute
- ;; info or when building DRV.
- (define references
- (references-oracle store (derivation-input drv outputs)))
-
(match (run-with-state
- (cumulative-grafts store drv grafts references
+ (cumulative-grafts store drv grafts
#:outputs outputs
#:guile guile #:system system)
vlist-null) ;the initial cache
diff --git a/guix/lint.scm b/guix/lint.scm
index 2be3cc3ee3..72582cfffb 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -308,6 +308,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"intltool"
"itstool"
"libtool"
+ "m4"
"qttools"
"yasm" "nasm" "fasm"
"python-coverage" "python2-coverage"
diff --git a/guix/packages.scm b/guix/packages.scm
index 567240f54e..58078c75c0 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -111,6 +111,8 @@
package-output
package-grafts
package-patched-vulnerabilities
+ package-with-patches
+ package-with-extra-patches
package/inherit
transitive-input-references
@@ -656,6 +658,18 @@ specifies modules in scope when evaluating SNIPPET."
#:properties `((type . origin)
(patches . ,(length patches)))))))
+(define (package-with-patches original patches)
+ "Return package ORIGINAL with PATCHES applied."
+ (package (inherit original)
+ (source (origin (inherit (package-source original))
+ (patches patches)))))
+
+(define (package-with-extra-patches original patches)
+ "Return package ORIGINAL with all PATCHES appended to its list of patches."
+ (package-with-patches original
+ (append (origin-patches (package-source original))
+ patches)))
+
(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/profiles.scm b/guix/profiles.scm
index 9150886081..7bcf4e3172 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -87,6 +87,9 @@
manifest-entry-search-paths
manifest-entry-parent
manifest-entry-properties
+ lower-manifest-entry
+
+ manifest-entry=?
manifest-pattern
manifest-pattern?
@@ -216,6 +219,33 @@
(output manifest-pattern-output ; string | #f
(default "out")))
+(define (list=? = lst1 lst2)
+ "Return true if LST1 and LST2 have the same length and their elements are
+pairwise equal per =."
+ (match lst1
+ (()
+ (null? lst2))
+ ((head1 . tail1)
+ (match lst2
+ ((head2 . tail2)
+ (and (= head1 head2) (list=? = tail1 tail2)))
+ (()
+ #f)))))
+
+(define (manifest-entry=? entry1 entry2)
+ "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties'
+field."
+ (match entry1
+ (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1)
+ (match entry2
+ (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2)
+ (and (string=? name1 name2)
+ (string=? version1 version2)
+ (string=? output1 output2)
+ (equal? item1 item2) ;XXX: could be <package> vs. store item
+ (equal? paths1 paths2)
+ (list=? manifest-entry=? dependencies1 dependencies2)))))))
+
(define (manifest-transitive-entries manifest)
"Return the entries of MANIFEST along with their propagated inputs,
recursively."
@@ -263,16 +293,24 @@ procedure takes two arguments: the entry name and output."
(define* (lower-manifest-entry entry system #:key target)
"Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
file name."
+ (define (recurse entry)
+ (mapm/accumulate-builds (lambda (entry)
+ (lower-manifest-entry entry system
+ #:target target))
+ (manifest-entry-dependencies entry)))
+
(let ((item (manifest-entry-item entry)))
(if (string? item)
(with-monad %store-monad
(return entry))
(mlet %store-monad ((drv (lower-object item system
#:target target))
+ (dependencies (recurse entry))
(output -> (manifest-entry-output entry)))
(return (manifest-entry
(inherit entry)
- (item (derivation->output-path drv output))))))))
+ (item (derivation->output-path drv output))
+ (dependencies dependencies)))))))
(define* (check-for-collisions manifest system #:key target)
"Check whether the entries of MANIFEST conflict with one another; raise a
@@ -1382,26 +1420,38 @@ the entries in MANIFEST."
#~(begin
(use-modules (guix man-db)
(guix build utils)
+ (ice-9 threads)
(srfi srfi-1)
(srfi srfi-19))
+ (define (print-string msg)
+ (display msg)
+ (force-output))
+
+ (define-syntax-rule (print fmt args ...)
+ ;; Build up the string and display it at once.
+ (print-string (format #f fmt args ...)))
+
+ (define (compute-entry directory count total)
+ (print "\r[~3d/~3d] building list of man-db entries..."
+ count total)
+ (let ((man (string-append directory "/share/man")))
+ (if (directory-exists? man)
+ (mandb-entries man)
+ '())))
+
(define (compute-entries)
;; This is the most expensive part (I/O and CPU, due to
;; decompression), so report progress as we traverse INPUTS.
- (let* ((inputs '#$(manifest-inputs manifest))
- (total (length inputs)))
- (append-map (lambda (directory count)
- (format #t "\r[~3d/~3d] building list of \
-man-db entries..."
- count total)
- (force-output)
- (let ((man (string-append directory
- "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- inputs
- (iota total 1))))
+ ;; Cap at 4 threads because we don't see any speedup beyond that
+ ;; on an SSD laptop.
+ (let* ((inputs '#$(manifest-inputs manifest))
+ (total (length inputs))
+ (threads (min (parallel-job-count) 4)))
+ (concatenate
+ (n-par-map threads compute-entry inputs
+ (iota total 1)
+ (make-list total total)))))
(define man-directory
(string-append #$output "/share/man"))
diff --git a/guix/records.scm b/guix/records.scm
index 4bda5426a3..3d54a51956 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -24,6 +24,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:autoload (system base target) (target-most-positive-fixnum)
#:export (define-record-type*
this-record
@@ -360,7 +361,9 @@ inherited."
(((field get properties ...) ...)
(string-hash (object->string
(syntax->datum #'((field properties ...) ...)))
- most-positive-fixnum))))
+ (cond-expand
+ (guile-3 (target-most-positive-fixnum))
+ (else most-positive-fixnum))))))
(syntax-case s ()
((_ type syntactic-ctor ctor pred
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a4b38735a7..4f72304e57 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1128,4 +1128,5 @@ to your package list.")))
gc-root))
(return (format #t "~a~%"
(derivation->output-path drv))))))
+ #:target target
#:system (assoc-ref opts 'system)))))))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 304084796a..b2b734aadd 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -197,6 +197,10 @@ non-zero relevance score."
(define (transaction-upgrade-entry store entry transaction)
"Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
<manifest-entry>."
+ (define (lower-manifest-entry* entry)
+ (run-with-store store
+ (lower-manifest-entry entry (%current-system))))
+
(define (supersede old new)
(info (G_ "package '~a' has been superseded by '~a'~%")
(manifest-entry-name old) (package-name new))
@@ -209,40 +213,44 @@ non-zero relevance score."
(output (manifest-entry-output old)))
transaction)))
- (match (if (manifest-transaction-removal-candidate? entry transaction)
- 'dismiss
- entry)
- ('dismiss
- transaction)
- (($ <manifest-entry> name version output (? string? path))
- (match (find-best-packages-by-name name #f)
- ((pkg . rest)
- (let ((candidate-version (package-version pkg)))
- (match (package-superseded pkg)
- ((? package? new)
- (supersede entry new))
- (#f
- (case (version-compare candidate-version version)
- ((>)
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction))
- ((<)
- transaction)
- ((=)
- (let ((candidate-path (derivation->output-path
- (package-derivation store pkg))))
- ;; XXX: When there are propagated inputs, assume we need to
- ;; upgrade the whole entry.
- (if (and (string=? path candidate-path)
- (null? (package-propagated-inputs pkg)))
- transaction
- (manifest-transaction-install-entry
- (package->manifest-entry* pkg output)
- transaction)))))))))
- (()
- (warning (G_ "package '~a' no longer exists~%") name)
- transaction)))))
+ (define (upgrade entry)
+ (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)))
+ (match (package-superseded pkg)
+ ((? package? new)
+ (supersede entry new))
+ (#f
+ (case (version-compare candidate-version version)
+ ((>)
+ (manifest-transaction-install-entry
+ (package->manifest-entry* pkg output)
+ transaction))
+ ((<)
+ transaction)
+ ((=)
+ (let* ((new (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
+ ;; displaying the list of packages to install/upgrade
+ ;; upfront. Thus, if lowering NEW triggers a build (due
+ ;; to grafts), assume NEW differs from ENTRY.
+ (if (with-build-handler (const #f)
+ (manifest-entry=? (lower-manifest-entry* new)
+ entry))
+ transaction
+ (manifest-transaction-install-entry
+ new transaction)))))))))
+ (()
+ (warning (G_ "package '~a' no longer exists~%") name)
+ transaction)))))
+
+ (if (manifest-transaction-removal-candidate? entry transaction)
+ transaction
+ (upgrade entry)))
;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index a178761203..2664c66a30 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -258,7 +258,7 @@ expression in %STORE-MONAD."
(lambda ()
(guard (c ((shepherd-error? c)
(values (report-shepherd-error c) store)))
- (values (run-with-store store (begin mbody ...))
+ (values (run-with-store store (mbegin %store-monad mbody ...))
store)))
(lambda (key proc format-string format-args errno . rest)
(warning (G_ "while talking to shepherd: ~a~%")
@@ -290,22 +290,6 @@ on service '~a':~%")
((not error) ;not an error
#t)))
-(define (call-with-service-upgrade-info new-services mproc)
- "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
-names of services to load (upgrade), and the list of names of services to
-unload."
- (match (current-services)
- ((services ...)
- (let-values (((to-unload to-restart)
- (shepherd-service-upgrade services new-services)))
- (mproc to-restart
- (map (compose first live-service-provision)
- to-unload))))
- (#f
- (with-monad %store-monad
- (warning (G_ "failed to obtain list of shepherd services~%"))
- (return #f)))))
-
(define-syntax-rule (unless-file-not-found exp)
(catch 'system-error
(lambda ()
@@ -825,10 +809,10 @@ static checks."
;; For 'init' and 'reconfigure', always build BOOTCFG, even if
;; --no-bootloader is passed, because we then use it as a GC root.
;; See <http://bugs.gnu.org/21068>.
- (drvs (mapm %store-monad lower-object
- (if (memq action '(init reconfigure))
- (list sys bootcfg)
- (list sys))))
+ (drvs (mapm/accumulate-builds lower-object
+ (if (memq action '(init reconfigure))
+ (list sys bootcfg)
+ (list sys))))
(% (if derivations-only?
(return (for-each (compose println derivation-file-name)
drvs))
@@ -853,7 +837,10 @@ static checks."
(info (G_ "bootloader successfully installed on '~a'~%")
(bootloader-configuration-target bootloader))))
(with-shepherd-error-handling
- (upgrade-shepherd-services local-eval os))))
+ (upgrade-shepherd-services local-eval os)
+ (return (format #t (G_ "\
+To complete the upgrade, run 'herd restart SERVICE' to stop,
+upgrade, and restart each service that was not automatically restarted.\n"))))))
((init)
(newline)
(format #t (G_ "initializing operating system under '~a'...~%")
@@ -1294,7 +1281,6 @@ argument list and OPTS is the option alist."
(process-command command args opts))))))
;;; Local Variables:
-;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
;;; eval: (put 'with-store* 'scheme-indent-function 1)
;;; End:
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 77a72307b4..7885c33457 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
@@ -33,6 +33,7 @@
#:use-module (guix modules)
#:use-module (guix monads)
#:use-module (guix store)
+ #:use-module ((guix self) #:select (make-config.scm))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -60,6 +61,14 @@
;;; Profile creation.
;;;
+(define not-config?
+ ;; Select (guix …) and (gnu …) modules, except (guix config).
+ (match-lambda
+ (('guix 'config) #f)
+ (('guix rest ...) #t)
+ (('gnu rest ...) #t)
+ (_ #f)))
+
(define* (switch-system-program os #:optional profile)
"Return an executable store item that, upon being evaluated, will create a
new generation of PROFILE pointing to the directory of OS, switch to it
@@ -67,9 +76,11 @@ atomically, and run OS's activation script."
(program-file
"switch-to-system.scm"
(with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((guix config)
- (guix profiles)
- (guix utils)))
+ (with-imported-modules `(,@(source-module-closure
+ '((guix profiles)
+ (guix utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (guix config)
(guix profiles)
@@ -89,7 +100,8 @@ atomically, and run OS's activation script."
"Using EVAL, a monadic procedure taking a single G-Expression as an argument,
create a new generation of PROFILE pointing to the directory of OS, switch to
it atomically, and run OS's activation script."
- (eval #~(primitive-load #$(switch-system-program os profile))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(switch-system-program os profile)))))
;;;
@@ -165,10 +177,11 @@ services as defined by OS."
(map live-service-canonical-name
live-services)))
(service-files (map shepherd-service-file target-services)))
- (eval #~(primitive-load #$(upgrade-services-program service-files
- to-start
- to-unload
- to-restart)))))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(upgrade-services-program service-files
+ to-start
+ to-unload
+ to-restart))))))))
;;;
@@ -184,10 +197,13 @@ BOOTLOADER-PACKAGE."
(program-file
"install-bootloader.scm"
(with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((gnu build bootloader)
- (gnu build install)
- (guix store)
- (guix utils)))
+ (with-imported-modules `(,@(source-module-closure
+ '((gnu build bootloader)
+ (gnu build install)
+ (guix store)
+ (guix utils))
+ #:select? not-config?)
+ ((guix config) => ,(make-config.scm)))
#~(begin
(use-modules (gnu build bootloader)
(gnu build install)
@@ -195,8 +211,10 @@ BOOTLOADER-PACKAGE."
(guix store)
(guix utils)
(ice-9 binary-ports)
+ (ice-9 match)
(srfi srfi-34)
(srfi srfi-35))
+
(let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
(new-gc-root (string-append gc-root ".new")))
;; #$bootcfg has dependencies.
@@ -218,7 +236,11 @@ BOOTLOADER-PACKAGE."
(#$installer #$bootloader-package #$device #$target))
(lambda args
(delete-file new-gc-root)
- (apply throw args))))
+ (match args
+ (('%exception exception) ;Guile 3 SRFI-34 or similar
+ (raise-exception exception))
+ ((key . args)
+ (apply throw key args))))))
;; We are sure that the installation of the bootloader
;; succeeded, so we can replace the old GC root by the new
;; GC root now.
@@ -237,9 +259,10 @@ additional configurations specified by MENU-ENTRIES can be selected."
(package (bootloader-package bootloader))
(device (bootloader-configuration-target configuration))
(bootcfg-file (bootloader-configuration-file bootloader)))
- (eval #~(primitive-load #$(install-bootloader-program installer
- package
- bootcfg
- bootcfg-file
- device
- target)))))
+ (eval #~(parameterize ((current-warning-port (%make-void-port "w")))
+ (primitive-load #$(install-bootloader-program installer
+ package
+ bootcfg
+ bootcfg-file
+ device
+ target))))))
diff --git a/guix/store.scm b/guix/store.scm
index 12f66d0e71..6c7c07fd2d 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -624,14 +624,25 @@ connection. Use with care."
(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)))
- (proc store)))
- (lambda ()
- (false-if-exception (close-connection store))))))
+ (define (thunk)
+ (parameterize ((current-store-protocol-version
+ (store-connection-version store)))
+ (let ((result (proc store)))
+ (close-connection store)
+ result)))
+
+ (cond-expand
+ (guile-3
+ (with-exception-handler (lambda (exception)
+ (close-connection store)
+ (raise-exception exception))
+ thunk))
+ (else ;Guile 2.2
+ (catch #t
+ thunk
+ (lambda (key . args)
+ (close-connection store)
+ (apply throw key args)))))))
(define-syntax-rule (with-store store exp ...)
"Bind STORE to an open connection to the store and evaluate EXPs;
diff --git a/guix/ui.scm b/guix/ui.scm
index 1e24fe5dca..1ccc80a000 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1164,7 +1164,7 @@ separator between subsequent columns."
names outputs)
(map (lambda (old new)
(if (string=? old new)
- (G_ "(dependencies changed)")
+ (G_ "(dependencies or package changed)")
(string-append old " " → " " new)))
old-version new-version))
#:initial-indent 3))