From 190ddfe21e3d87719733d12fb9b5eb176125a49f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 21:48:51 +0200 Subject: guix package: 'transaction-upgrade-entry' uses 'lower-manifest-entry'. * guix/profiles.scm (lower-manifest-entry): Export. * guix/scripts/package.scm (transaction-upgrade-entry)[lower-manifest-entry*] [upgrade]: New procedures. Use 'lower-manifest-entry*' instead of 'package-derivation' to compute the output file name of PKG. --- guix/profiles.scm | 2 ++ guix/scripts/package.scm | 73 ++++++++++++++++++++++++++---------------------- 2 files changed, 41 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index ad9878f370..1362c4092a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -87,6 +87,7 @@ manifest-entry-search-paths manifest-entry-parent manifest-entry-properties + lower-manifest-entry manifest-pattern manifest-pattern? @@ -272,6 +273,7 @@ file name." (output -> (manifest-entry-output entry))) (return (manifest-entry (inherit entry) + ;; TODO: Lower dependencies, recursively. (item (derivation->output-path drv output)))))))) (define* (check-for-collisions manifest system #:key target) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c7908ece6c..be2e67997e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -199,6 +199,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 ." + (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)) @@ -211,40 +215,41 @@ non-zero relevance score." (output (manifest-entry-output old))) transaction))) - (match (if (manifest-transaction-removal-candidate? entry transaction) - 'dismiss - entry) - ('dismiss - transaction) - (($ 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 + (($ 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))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? (manifest-entry-item + (lower-manifest-entry* new)) + (manifest-entry-item entry)) + (null? (package-propagated-inputs pkg))) + 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))) ;;; -- cgit v1.2.3 From a187cc562890895ad41dfad00eb1d5c4a4b00936 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 22:11:54 +0200 Subject: guix package: 'transaction-upgrade-entry' swallows build requests. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes a regression introduced in 131f50cdc9dbb7183023f4dae759876a9e700bef whereby the install/upgrade message would not be displayed: $ guix upgrade -n 2.1 MB would be downloaded: /gnu/store/…-something-1.2 /gnu/store/…-its-dependency-2.3 This is because we'd directly abort from 'transaction-upgrade-entry' to the build handler of 'build-notifier'. * guix/scripts/package.scm (transaction-upgrade-entry): Call 'string=?' expression in 'with-build-handler'. * tests/packages.scm ("transaction-upgrade-entry, grafts"): New test. --- guix/scripts/package.scm | 14 +++++++++++--- tests/packages.scm | 24 ++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index be2e67997e..cafa62c3f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -234,11 +234,19 @@ non-zero relevance score." 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. + ;; XXX: When there are propagated inputs, assume we need to ;; upgrade the whole entry. - (if (and (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry)) + (if (and (with-build-handler (const #f) + (string=? (manifest-entry-item + (lower-manifest-entry* new)) + (manifest-entry-item entry))) (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry diff --git a/tests/packages.scm b/tests/packages.scm index 1ff35ec9c4..c2ec1f2c24 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -148,6 +148,30 @@ (string=? (manifest-pattern-version pattern) "1") (string=? (manifest-pattern-output pattern) "out"))))))) +(test-assert "transaction-upgrade-entry, grafts" + ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't + ;; try to build stuff. + (with-build-handler (const 'failed!) + (parameterize ((%graft? #t)) + (let* ((old (dummy-package "foo" (version "1"))) + (bar (dummy-package "bar" (version "0") + (replacement old))) + (new (dummy-package "foo" (version "1") + (inputs `(("bar" ,bar))))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list new))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "foo" "1" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 1a9a373eb445d21add006a46c18df0da11e52cbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 22:39:54 +0200 Subject: profiles: 'lower-manifest-entry' recurses on dependencies. * guix/profiles.scm (lower-manifest-entry)[recurse]: New procedure. Call it on dependencies and set the 'dependencies' field accordingly. --- guix/profiles.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 1362c4092a..e3bbc6dd6d 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -264,17 +264,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) - ;; TODO: Lower dependencies, recursively. - (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 -- cgit v1.2.3 From a357849f5b1314c2a35efeee237645b9b08c39f5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Mar 2020 23:34:48 +0200 Subject: guix package: Do not misdiagnose upgrades when there are propagated inputs. Fixes . Reported by Andy Tai . * guix/profiles.scm (list=?, manifest-entry=?): New procedures. * guix/scripts/package.scm (transaction-upgrade-entry): In the '=' case, use 'manifest-entry=?' to determine whether it's an upgrade. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades, propagated inputs"): New test. --- guix/profiles.scm | 29 +++++++++++++++++++++++++++++ guix/scripts/package.scm | 11 +++-------- tests/packages.scm | 22 ++++++++++++++++++++++ 3 files changed, 54 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index e3bbc6dd6d..8aa76a3537 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -89,6 +89,8 @@ manifest-entry-properties lower-manifest-entry + manifest-entry=? + manifest-pattern manifest-pattern? manifest-pattern-name @@ -217,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 + (($ name1 version1 output1 item1 dependencies1 paths1) + (match entry2 + (($ name2 version2 output2 item2 dependencies2 paths2) + (and (string=? name1 name2) + (string=? version1 version2) + (string=? output1 output2) + (equal? item1 item2) ;XXX: could be 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." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index cafa62c3f3..badb1dcd38 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -240,14 +240,9 @@ non-zero relevance score." ;; displaying the list of packages to install/upgrade ;; upfront. Thus, if lowering NEW triggers a build (due ;; to grafts), assume NEW differs from ENTRY. - - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (with-build-handler (const #f) - (string=? (manifest-entry-item - (lower-manifest-entry* new)) - (manifest-entry-item entry))) - (null? (package-propagated-inputs pkg))) + (if (with-build-handler (const #f) + (manifest-entry=? (lower-manifest-entry* new) + entry)) transaction (manifest-transaction-install-entry new transaction))))))))) diff --git a/tests/packages.scm b/tests/packages.scm index d0befbe45d..7a8b5e4a2d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -122,6 +122,28 @@ (manifest-transaction))))) (manifest-transaction-null? tx))) +(test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs" + ;; Properly detect equivalent packages even when they have propagated + ;; inputs. See . + (let* ((dep (dummy-package "dep" (version "2"))) + (old (dummy-package "foo" (version "1") + (propagated-inputs `(("dep" ,dep))))) + (drv (package-derivation %store old)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list old))) + (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (item (derivation->output-path drv)) + (dependencies + (list (manifest-entry + (inherit (package->manifest-entry dep)) + (item (derivation->output-path + (package-derivation %store dep))))))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) -- cgit v1.2.3 From 2c33901fb1f580b50d9649d5e93928172c5d12b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Mar 2020 12:30:21 +0200 Subject: ci: Fix 'evaluation-spec' binding. * guix/ci.scm ()[spec]: Add "specification", which is what the JSON field is actually called. --- guix/ci.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,7 +68,7 @@ (define-json-mapping 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) -- cgit v1.2.3 From ef4b5f2fed3ca13a0e15a821ba7e561cd4395aa6 Mon Sep 17 00:00:00 2001 From: Arne Babenhauserheide Date: Fri, 12 Jul 2019 23:42:45 +0200 Subject: profiles: Compute manual database entries in parallel. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This provides a 36% speedup on an SSD and 4 cores for the 1.5K man pages in the manual database derivation of: guix environment --ad-hoc jupyter python-ipython python-ipykernel * guix/profiles.scm (manual-database)[build]: Add 'print-string', 'print', and 'compute-entry'. Change 'compute-entries' to call 'compute-entry' in 'n-par-map'. Co-authored-by: Ludovic Courtès --- guix/profiles.scm | 40 ++++++++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8aa76a3537..47a7c92569 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1418,26 +1418,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")) -- cgit v1.2.3 From 4b75a7060058bc2e959dcb4145067f6bba3e34e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 1 Apr 2020 22:51:46 +0200 Subject: grafts: Simplify access to store item references. This is a followup to 710854304b1ab29332edcb76f3de532e0724c197. This also slightly reduces the number of 'query-references' RPCs, for instance from 176 to 166 from "guix build emacs -d". * guix/grafts.scm (references-oracle): Remove. (non-self-references): Remove 'references' parameter and add 'store'. Add 'references*' procedure and use it instead of 'references'. Adjust caller accordingly. (cumulative-grafts): Remove 'references' parameter and adjust caller accordingly. --- guix/grafts.scm | 60 +++++++++++++++------------------------------------------ 1 file changed, 15 insertions(+), 45 deletions(-) (limited to 'guix') 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 -- cgit v1.2.3 From 5c83dd1d64783d4829e42714be41f4c4b0430dbd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 09:47:58 +0200 Subject: ui: Clarify "dependencies changed". Suggested by Leo Famulari . * guix/ui.scm (show-manifest-transaction): Change to "dependencies or package changed". --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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)) -- cgit v1.2.3 From 2ad6eb0568ed69127aea987c009138e03b5b8954 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 10:58:38 +0200 Subject: guix system: Use 'mapm/accumulate-builds'. * guix/scripts/system.scm (perform-action): Use 'mapm/accumulate-builds' instead of 'mapm'. --- guix/scripts/system.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a178761203..4937e68115 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -825,10 +825,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 . - (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)) -- cgit v1.2.3 From b34ead48dcd3f3aff27b21d7a326f9bdfd3b2235 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 10:59:15 +0200 Subject: gexp: 'lower-references' uses 'mapm/accumulate-builds'. * guix/gexp.scm (lower-references): Use 'mapm/accumulate-builds' instead of 'mapm'. --- guix/gexp.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 3d21685460..4ac0411da1 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. -- cgit v1.2.3 From 3b4d7cdccce97dbffee538812c86bc03a6ae35d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 14:17:36 +0200 Subject: bournish: Prevent inlining of run-time support procedures. On Guile 3, those procedures could be inlined, leading to unbound-variable errors: scheme@(guile-user)> ,bournish Welcome to Bournish, a minimal Bourne-like shell! To switch back, type `,L scheme'. bournish@(guile-user)> ls ice-9/boot-9.scm:1669:16: In procedure raise-exception: Unbound variable: ls-command-implementation Reported by Ricardo Wurmus. * guix/build/bournish.scm (define-command-runtime): New macro. (ls-command-implementation, wc-command-implementation) (wc-l-command-implementation, wc-c-command-implementation): Use it instead of 'define'. --- guix/build/bournish.scm | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2016, 2017, 2020 Ludovic Courtès ;;; Copyright © 2016 Efraim Flashner ;;; Copyright © 2017 Ricardo Wurmus ;;; @@ -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) -- cgit v1.2.3 From efa578ecaece67366b4b0e2266de7c2faaa4ae54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 21:33:48 +0200 Subject: git: Don't try to resolve tags with 'tag-lookup'. Fixes . Reported by Brice Waegeneire . * guix/git.scm (switch-to-ref): In the 'tag case, remove call to 'tag-lookup'. --- guix/git.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') 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)) -- cgit v1.2.3 From a6850f6827869cd20feb1d4cc5abf6744b6cc164 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 22:09:43 +0200 Subject: guix system: Do not import the user's (guix config). Previously, 'switch-to-system.drv' and 'install-bootloader.drv' would depend on the user's (guix config) module. This is no longer the case. * guix/scripts/system/reconfigure.scm (not-config?): New procedure. (switch-system-program): Do not import the user's (guix config). Use 'make-config.scm' instead. (install-bootloader-program): Likewise. --- guix/scripts/system/reconfigure.scm | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 77a72307b4..c8d1ed4a51 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 +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe @@ -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) @@ -184,10 +195,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) @@ -197,6 +211,7 @@ BOOTLOADER-PACKAGE." (ice-9 binary-ports) (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. -- cgit v1.2.3 From 5517750344be05c91bc2979c1a0e2348a9ae902d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 2 Apr 2020 22:46:18 +0200 Subject: reconfigure: Run the effect scripts as separate processes. Fixes . Reported by strypsteen@posteo.net. * guix/scripts/system/reconfigure.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Use 'system*' instead of 'primitive-load'. --- guix/scripts/system/reconfigure.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index c8d1ed4a51..21b472e0c5 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,7 +100,7 @@ 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 #~(system* #$(switch-system-program os profile)))) ;;; @@ -176,10 +176,10 @@ 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 #~(system* #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) ;;; @@ -252,9 +252,9 @@ 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 #~(system* #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) -- cgit v1.2.3 From 00a1ebb84a5664cae1fbe0a0845d65c99d9907f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 10:26:54 +0200 Subject: Revert "reconfigure: Run the effect scripts as separate processes." This reverts commit 5517750344be05c91bc2979c1a0e2348a9ae902d. That commit would remove all sorts of error checking when running those programs. --- guix/scripts/system/reconfigure.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 21b472e0c5..c8d1ed4a51 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,7 +100,7 @@ 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 #~(system* #$(switch-system-program os profile)))) + (eval #~(primitive-load #$(switch-system-program os profile)))) ;;; @@ -176,10 +176,10 @@ services as defined by OS." (map live-service-canonical-name live-services))) (service-files (map shepherd-service-file target-services))) - (eval #~(system* #$(upgrade-services-program service-files - to-start - to-unload - to-restart))))))) + (eval #~(primitive-load #$(upgrade-services-program service-files + to-start + to-unload + to-restart))))))) ;;; @@ -252,9 +252,9 @@ 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 #~(system* #$(install-bootloader-program installer - package - bootcfg - bootcfg-file - device - target))))) + (eval #~(primitive-load #$(install-bootloader-program installer + package + bootcfg + bootcfg-file + device + target))))) -- cgit v1.2.3 From 9fb3ff31c15f36545bad11c1d9b11eaf0333f831 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 10:48:32 +0200 Subject: reconfigure: Silence Guile warnings. Fixes . Reported by strypsteen@posteo.net. * guix/scripts/system/reconfigure.scm (switch-to-system) (upgrade-shepherd-services, install-bootloader): Wrap 'primitive-load' call in 'parameterize'. --- guix/scripts/system/reconfigure.scm | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index c8d1ed4a51..074c48f58b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -100,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))))) ;;; @@ -176,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)))))))) ;;; @@ -252,9 +254,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)))))) -- cgit v1.2.3 From 4efbb079b5aac6a4eb53ef3f9a67a2849c3ebf1f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 11:22:46 +0200 Subject: guix system: Remove unused procedure. This procedure was unused since 5c8c8c455420af27189d6045b3599fe6e27ad012. * guix/scripts/system.scm (call-with-service-upgrade-info): Remove. --- guix/scripts/system.scm | 17 ----------------- 1 file changed, 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4937e68115..b87f2bdd3b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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 () @@ -1294,7 +1278,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: -- cgit v1.2.3 From 73bfb14f8ff105bbc8a8836f475f72867297fe93 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 11:42:01 +0200 Subject: guix system: Mention 'herd restart' when reconfigure completes. * guix/scripts/system.scm (with-shepherd-error-handling): Use 'mbegin' instead of 'begin'. (perform-action): Print a message after 'upgrade-shepherd-services'. That message had disappeared in commit 5c8c8c455420af27189d6045b3599fe6e27ad012. --- guix/scripts/system.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b87f2bdd3b..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~%") @@ -837,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'...~%") -- cgit v1.2.3 From f7b5b8cd45b4560b3473dde2e6f6f20b4ff9daff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Apr 2020 21:51:12 +0200 Subject: pack: Pass the cross-compilation target to 'run-with-store'. This ensures '%current-target-system' is correctly bound upfront, which some packages rely on. * guix/scripts/pack.scm (guix-pack): Pass #:target to 'run-with-store'. --- guix/scripts/pack.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f641f535b9..6d63fb4b90 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))))))))) -- cgit v1.2.3 From 8ed597f4a261fe188de82cd1f5daed83dba948eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 17:36:31 +0200 Subject: store: 'with-store' doesn't close the store upon abort. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Marius Bakke and 白い熊. Regression introduced with the first uses of 'with-build-handler' in commit 62195b9a8fd6846117c5d7698842748300d13e31 and subsequent. * guix/store.scm (call-with-store): Use 'catch #t' instead of 'dynamic-wind'. This ensures STORE remains open when a non-local exit other than an exception occurs, such as an abort to the build handler prompt. * tests/store.scm ("with-build-handler + with-store"): New test. --- guix/store.scm | 12 +++++++----- tests/store.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index ca8c0e5ef8..1dd5c9545b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,14 +623,16 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (dynamic-wind - (const #f) + (catch #t (lambda () (parameterize ((current-store-protocol-version (store-connection-version store))) - (proc store))) - (lambda () - (false-if-exception (close-connection store)))))) + (let ((result (proc store))) + (close-connection store) + result))) + (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/tests/store.scm b/tests/store.scm index 0458a34746..0e80ccc239 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -412,6 +412,33 @@ (build-derivations %store (list d2)) 'fail))) +(test-equal "with-build-handler + with-store" + 'success + ;; Check that STORE remains valid when the build handler invokes CONTINUE, + ;; even though 'with-build-handler' is outside the dynamic extent of + ;; 'with-store'. + (with-build-handler (lambda (continue store things mode) + (match things + ((drv) + (and (string-suffix? "thingie.drv" drv) + (not (port-closed? + (store-connection-socket store))) + (continue #t))))) + (with-store store + (let* ((b (add-text-to-store store "build" "echo $foo > $out" '())) + (s (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation store "thingie" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s)))) + (build-derivations store (list d)) + + ;; Here STORE's socket should still be open. + (and (valid-path? store (derivation->output-path d)) + 'success))))) + (test-assert "map/accumulate-builds" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" -- cgit v1.2.3 From 376ba0ce570993cf6cdbed19596a245826308382 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2020 23:58:05 +0200 Subject: store: 'with-store' uses 'with-exception-handler'. This ensures the stack is not unwound before the exception is re-thrown, as was the case since 8ed597f4a261fe188de82cd1f5daed83dba948eb, leading to '&store-protocol-error' being uncaught by 'with-error-handling' in (guix scripts build) & co. * guix/store.scm (call-with-store): Define 'thunk'. Add 'cond-expand' to use 'with-exception-handler' on 'guile-3' and 'catch' otherwise. --- guix/store.scm | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 1dd5c9545b..fb4b92e0c4 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -623,16 +623,25 @@ connection. Use with care." (define (call-with-store proc) "Call PROC with an open store connection." (let ((store (open-connection))) - (catch #t - (lambda () - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (let ((result (proc store))) - (close-connection store) - result))) - (lambda (key . args) - (close-connection store) - (apply throw key args))))) + (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; -- cgit v1.2.3 From b066c25026f21fb57677aa34692a5034338e7ee3 Mon Sep 17 00:00:00 2001 From: Carl Dong Date: Mon, 6 Apr 2020 14:02:42 -0400 Subject: gnu: Move PACKAGES-WITH-*PATCHES to (guix packages) * gnu/packages/cross-base.scm (package-with-extra-patches, package-with-patches): Move procedures from here... * guix/packages.scm (package-with-extra-patches, package-with-patches): ...to here, and export. --- gnu/packages/cross-base.scm | 12 ------------ guix/packages.scm | 14 ++++++++++++++ 2 files changed, 14 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index ae3ac210b7..b0eb7ab4ed 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -70,18 +70,6 @@ `(cons ,(string-append "--target=" target) ,flags)))))) -(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 (cross-binutils target) "Return a cross-Binutils for TARGET." (let ((binutils (package (inherit binutils) diff --git a/guix/packages.scm b/guix/packages.scm index 04d9b7824c..6c6a06e0ce 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 @@ -654,6 +656,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 -- cgit v1.2.3 From 42a87136f0c99c0f1956e053d92f23bf096bddb6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Apr 2020 23:21:43 +0200 Subject: channels: Call 'build-self.scm' procedure with a trivial build handler. Previously, "TESTS=installed-os guix build -m etc/system-tests.scm" would repeat the "Computing Guix derivation" phase ~5 times due to the fact that there were several call paths, within a build-accumulator, leading to (package-derivation store guix). * guix/channels.scm (with-trivial-build-handler): New procedure. (build-from-source): Wrap 'build' call in 'with-trivial-build-handler'. --- guix/channels.scm | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) (limited to 'guix') 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))) -- cgit v1.2.3 From 9ac6d3785f34d99034c27eb6f447b242d045b413 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 7 Apr 2020 17:58:05 +0200 Subject: lint: 'm4' is a native input. * guix/lint.scm (check-inputs-should-be-native): Add "m4". --- guix/lint.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') 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" -- cgit v1.2.3 From 9f1b787120b1b81abffaf0fa13fdbdf4cca39f2d Mon Sep 17 00:00:00 2001 From: TomZ Date: Tue, 7 Apr 2020 21:39:04 +0200 Subject: Allow double-click select of URL in status Various places while downloading or compiling guix prints the source URL. This change makes the URL easier to use by placing a space between the URL and the trailing dots. Signed-off-by: Marius Bakke --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 4b2edc2f3c..45e441eac5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ addition to build events." (let ((count (match (assq-ref properties 'graft) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "applying ~a graft for ~a..." - "applying ~a grafts for ~a..." + (format port (info (N_ "applying ~a graft for ~a ..." + "applying ~a grafts for ~a ..." count)) count drv))) ('profile (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package..." - "building profile with ~a packages..." + (format port (info (N_ "building profile with ~a package ..." + "building profile with ~a packages ..." count)) count))) ('profile-hook @@ -525,7 +525,7 @@ addition to build events." (newline port))) (('download-started item uri _ ...) (erase-current-line*) - (format port (info (G_ "downloading from ~a...")) uri) + (format port (info (G_ "downloading from ~a ...")) uri) (newline port)) (('download-progress item uri (= string->number size) -- cgit v1.2.3 From 1c86577d624b97a03138640b4d849823b504570e Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Tue, 7 Apr 2020 22:09:14 +0200 Subject: Revert "Allow double-click select of URL in status" As discussed on #guix, this should wait until 1.1.0 is branched off to avoid having to update translations. This reverts commit 9f1b787120b1b81abffaf0fa13fdbdf4cca39f2d. --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 45e441eac5..4b2edc2f3c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ addition to build events." (let ((count (match (assq-ref properties 'graft) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "applying ~a graft for ~a ..." - "applying ~a grafts for ~a ..." + (format port (info (N_ "applying ~a graft for ~a..." + "applying ~a grafts for ~a..." count)) count drv))) ('profile (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package ..." - "building profile with ~a packages ..." + (format port (info (N_ "building profile with ~a package..." + "building profile with ~a packages..." count)) count))) ('profile-hook @@ -525,7 +525,7 @@ addition to build events." (newline port))) (('download-started item uri _ ...) (erase-current-line*) - (format port (info (G_ "downloading from ~a ...")) uri) + (format port (info (G_ "downloading from ~a...")) uri) (newline port)) (('download-progress item uri (= string->number size) -- cgit v1.2.3 From 93add9bf7d73b6a6ed2d0cf85778b26aa38fd194 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:31:41 +0200 Subject: reconfigure: Correctly re-throw SRFI-34 exceptions on Guile 3. Previously, we'd just print an ugly backtrace when running on Guile 3 because the '%exception throw would not be caught anywhere. Reported by Arne Babenhauserheide in . * guix/scripts/system/reconfigure.scm (install-bootloader-program): In 'catch' handler, match '%exception and use 'raise-exception' instead of 'throw' to rethrow in that case. --- guix/scripts/system/reconfigure.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 074c48f58b..7885c33457 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -211,6 +211,7 @@ BOOTLOADER-PACKAGE." (guix store) (guix utils) (ice-9 binary-ports) + (ice-9 match) (srfi srfi-34) (srfi srfi-35)) @@ -235,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. -- cgit v1.2.3 From 041c3c22dc14d485ca58b3ae1436b62d4a39d0aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:48:54 +0200 Subject: compile: Run the load phase within 'with-target'. * guix/build/compile.scm (compile-files)[build]: Remove 'with-target'. Wrap body in 'with-target'. --- guix/build/compile.scm | 51 +++++++++++++++++++++++++------------------------- 1 file changed, 25 insertions(+), 26 deletions(-) (limited to 'guix') 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 , 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: - ;; . - (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 , 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: + ;; . + (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)) -- cgit v1.2.3 From a05ad011229cf3712d373918c2ed9ebdb5f5b2a2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Apr 2020 23:55:14 +0200 Subject: records: Have ABI check work well for cross-compilation. Reported by Jan (janneke) Nieuwenhuizen . * guix/records.scm (define-record-type*): Use 'target-most-positive-fixnum' on Guile 3 instead of 'most-positive-fixnum'. --- guix/records.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') 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 -- cgit v1.2.3