summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2020-03-30 12:17:33 +0200
committerMarius Bakke <mbakke@fastmail.com>2020-03-30 12:17:33 +0200
commitae0badf5bb791428423a98d4e4e2b8d297a5d4be (patch)
tree4282d243db3e90839a5f7d3b5878674ccd0e2e14 /guix
parentee401ed9249fbe284ef1b9b437d39207ca88131b (diff)
parent927f3655662b41f25225ea03baa3ded687aa7cbb (diff)
Merge branch 'master' into core-updates
Conflicts: gnu/packages/admin.scm gnu/packages/commencement.scm gnu/packages/guile.scm gnu/packages/linux.scm gnu/packages/package-management.scm gnu/packages/pulseaudio.scm gnu/packages/web.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/gnu.scm4
-rw-r--r--guix/gexp.scm32
-rw-r--r--guix/grafts.scm20
-rw-r--r--guix/packages.scm76
-rw-r--r--guix/profiles.scm57
-rw-r--r--guix/scripts/archive.scm2
-rw-r--r--guix/scripts/build.scm8
-rw-r--r--guix/scripts/copy.scm2
-rw-r--r--guix/scripts/deploy.scm46
-rw-r--r--guix/scripts/environment.scm2
-rw-r--r--guix/scripts/pack.scm2
-rw-r--r--guix/scripts/package.scm3
-rw-r--r--guix/scripts/pull.scm2
-rw-r--r--guix/scripts/system.scm2
-rw-r--r--guix/store.scm64
15 files changed, 197 insertions, 125 deletions
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index d6613edb33..f59567febb 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -151,8 +151,8 @@ so that they use INPUTS (a thunk) instead of implicit inputs."
p))
(define (cut? p)
- (and (eq? (package-build-system p) gnu-build-system)
- (memq #:implicit-inputs? (package-arguments p))))
+ (or (not (eq? (package-build-system p) gnu-build-system))
+ (memq #:implicit-inputs? (package-arguments p))))
(package-mapping add-explicit-inputs cut?))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 99390bcafc..1f1993a89f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -683,22 +683,22 @@ When TARGET is true, use it as the cross-compilation target triplet."
(and (string? obj) (store-path? obj)))
(with-monad %store-monad
- (mapm %store-monad
- (match-lambda
- (((? struct? thing) sub-drv ...)
- (mlet %store-monad ((obj (lower-object
- thing system #:target target)))
- (return (match obj
- ((? derivation? drv)
- (let ((outputs (if (null? sub-drv)
- '("out")
- sub-drv)))
- (derivation-input drv outputs)))
- ((? store-item? item)
- item)))))
- (((? store-item? item))
- (return item)))
- inputs)))
+ (mapm/accumulate-builds
+ (match-lambda
+ (((? struct? thing) sub-drv ...)
+ (mlet %store-monad ((obj (lower-object
+ thing system #:target target)))
+ (return (match obj
+ ((? derivation? drv)
+ (let ((outputs (if (null? sub-drv)
+ '("out")
+ sub-drv)))
+ (derivation-input drv outputs)))
+ ((? store-item? item)
+ item)))))
+ (((? store-item? item))
+ (return item)))
+ inputs)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
diff --git a/guix/grafts.scm b/guix/grafts.scm
index adc7bfafae..5173a77e58 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.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>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -166,22 +166,14 @@ references. Call REFERENCES to get the list of references."
(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. Use either local info or substitute info; build
-INPUT if no information is available."
+references of that item. Build INPUT if it's not available."
(define (references* items)
+ ;; Return the references of ITEMS.
(guard (c ((store-protocol-error? c)
- ;; As a last resort, build DRV and query the references of the
- ;; build result.
-
- ;; Warm up the narinfo cache, otherwise each derivation build
- ;; will result in one HTTP request to get one narinfo, which is
- ;; much less efficient than fetching them all upfront.
- (substitution-oracle store
- (list (derivation-input-derivation input)))
-
+ ;; ITEMS are not in store so build INPUT first.
(and (build-derivations store (list input))
- (map (cut references store <>) items))))
- (references/substitutes store items)))
+ (map (cut references/cached store <>) items))))
+ (map (cut references/cached store <>) items)))
(let loop ((items (derivation-input-output-paths input))
(result vlist-null))
diff --git a/guix/packages.scm b/guix/packages.scm
index ef96b5692f..567240f54e 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -444,9 +444,9 @@ derivations."
(let ((distro (resolve-interface '(gnu packages commencement))))
(module-ref distro 'guile-final)))
-(define (guile-2.0)
- "Return Guile 2.0."
- ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
+(define (guile-for-grafts)
+ "Return the Guile package used to build grafting derivations."
+ ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
;; grafting packages.
(let ((distro (resolve-interface '(gnu packages guile))))
(module-ref distro 'guile-2.0)))
@@ -1031,39 +1031,39 @@ information in exceptions."
#:key (graft? (%graft?)))
"Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
and return it."
- (cached (=> %bag-cache)
- package (list system target graft?)
- ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
- ;; field values can refer to it.
- (parameterize ((%current-system system)
- (%current-target-system target))
- (match (if graft?
- (or (package-replacement package) package)
- package)
- ((and self
- ($ <package> name version source build-system
- args inputs propagated-inputs native-inputs
- outputs))
- ;; Even though we prefer to use "@" to separate the package
- ;; name from the package version in various user-facing parts
- ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
- ;; prohibits the use of "@", so use "-" instead.
- (or (make-bag build-system (string-append name "-" version)
- #:system system
- #:target target
- #:source source
- #:inputs (append (inputs self)
- (propagated-inputs self))
- #:outputs outputs
- #:native-inputs (native-inputs self)
- #:arguments (args self))
- (raise (if target
- (condition
- (&package-cross-build-system-error
- (package package)))
- (condition
- (&package-error
- (package package)))))))))))
+ (let ((package (or (and graft? (package-replacement package))
+ package)))
+ (cached (=> %bag-cache)
+ package (list system target)
+ ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
+ ;; field values can refer to it.
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (match package
+ ((and self
+ ($ <package> name version source build-system
+ args inputs propagated-inputs native-inputs
+ outputs))
+ ;; Even though we prefer to use "@" to separate the package
+ ;; name from the package version in various user-facing parts
+ ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
+ ;; prohibits the use of "@", so use "-" instead.
+ (or (make-bag build-system (string-append name "-" version)
+ #:system system
+ #:target target
+ #:source source
+ #:inputs (append (inputs self)
+ (propagated-inputs self))
+ #:outputs outputs
+ #:native-inputs (native-inputs self)
+ #:arguments (args self))
+ (raise (if target
+ (condition
+ (&package-cross-build-system-error
+ (package package)))
+ (condition
+ (&package-error
+ (package package))))))))))))
(define %graft-cache
;; 'eq?' cache mapping package objects to a graft corresponding to their
@@ -1271,7 +1271,7 @@ This is an internal procedure."
(()
drv)
(grafts
- (let ((guile (package-derivation store (guile-2.0)
+ (let ((guile (package-derivation store (guile-for-grafts)
system #:graft? #f)))
;; TODO: As an optimization, we can simply graft the tip
;; of the derivation graph since 'graft-derivation'
@@ -1297,7 +1297,7 @@ system identifying string)."
(graft-derivation store drv grafts
#:system system
#:guile
- (package-derivation store (guile-2.0)
+ (package-derivation store (guile-for-grafts)
system #:graft? #f))))
drv))))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 2a838d3a9a..9150886081 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -280,29 +280,37 @@ file name."
(define lookup
(manifest-entry-lookup manifest))
- (with-monad %store-monad
+ (define candidates
+ (filter-map (lambda (entry)
+ (let ((other (lookup (manifest-entry-name entry)
+ (manifest-entry-output entry))))
+ (and other (list entry other))))
+ (manifest-transitive-entries manifest)))
+
+ (define lower-pair
+ (match-lambda
+ ((first second)
+ (mlet %store-monad ((first (lower-manifest-entry first system
+ #:target target))
+ (second (lower-manifest-entry second system
+ #:target target)))
+ (return (list first second))))))
+
+ ;; Start by lowering CANDIDATES "in parallel".
+ (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates)))
(foldm %store-monad
- (lambda (entry result)
- (match (lookup (manifest-entry-name entry)
- (manifest-entry-output entry))
- ((? manifest-entry? second) ;potential conflict
- (mlet %store-monad ((first (lower-manifest-entry entry system
- #:target
- target))
- (second (lower-manifest-entry second system
- #:target
- target)))
- (if (string=? (manifest-entry-item first)
- (manifest-entry-item second))
- (return result)
- (raise (condition
- (&profile-collision-error
- (entry first)
- (conflict second)))))))
- (#f ;no conflict
- (return result))))
+ (lambda (entries result)
+ (match entries
+ ((first second)
+ (if (string=? (manifest-entry-item first)
+ (manifest-entry-item second))
+ (return result)
+ (raise (condition
+ (&profile-collision-error
+ (entry first)
+ (conflict second))))))))
#t
- (manifest-transitive-entries manifest))))
+ lst)))
(define* (package->manifest-entry package #:optional (output "out")
#:key (parent (delay #f))
@@ -1523,10 +1531,9 @@ are cross-built for TARGET."
#:target target)))
(extras (if (null? (manifest-entries manifest))
(return '())
- (mapm %store-monad
- (lambda (hook)
- (hook manifest))
- hooks))))
+ (mapm/accumulate-builds (lambda (hook)
+ (hook manifest))
+ hooks))))
(define inputs
(append (filter-map (lambda (drv)
(and (derivation? drv)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 80f3b704d7..41a2a42c21 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -183,7 +183,7 @@ Export/import one or more packages from/to the store.\n"))
(alist-delete 'verbosity result)))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
%standard-build-options))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index af18d8b6f9..79bd84a1a0 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -778,7 +778,7 @@ must be one of 'package', 'all', or 'transitive'~%")
(alist-cons 'manifest arg result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\r "root") #t #f
(lambda (opt name arg result)
(alist-cons 'gc-root arg result)))
@@ -920,8 +920,10 @@ build."
(with-unbound-variable-handling
(parameterize ((%graft? graft?))
(append-map (lambda (system)
- (append-map (cut compute-derivation <> system)
- things-to-build))
+ (concatenate
+ (map/accumulate-builds store
+ (cut compute-derivation <> system)
+ things-to-build)))
systems))))
(define (show-build-log store file urls)
diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm
index 2fa31ecf45..f6f64d0a11 100644
--- a/guix/scripts/copy.scm
+++ b/guix/scripts/copy.scm
@@ -135,7 +135,7 @@ Copy ITEMS to or from the specified host over SSH.\n"))
(alist-delete 'verbosity result)))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\h "help") #f #f
(lambda args
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index f70d41f35c..4466a0c632 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -30,6 +30,7 @@
#:use-module (guix status)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
@@ -102,7 +103,7 @@ Perform the deployment specified by FILE.\n"))
"Show the list of machines to deploy, MACHINES."
(let ((count (length machines)))
(format (current-error-port)
- (N_ "The following ~*machine will be deployed:~%"
+ (N_ "The following ~d machine will be deployed:~%"
"The following ~d machines will be deployed:~%"
count)
count)
@@ -114,6 +115,27 @@ Perform the deployment specified by FILE.\n"))
(current-error-port))
(display "\n\n" (current-error-port))))
+(define (deploy-machine* store machine)
+ "Deploy MACHINE, taking care of error handling."
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
+
+ (guard (c ((message-condition? c)
+ (report-error (G_ "failed to deploy ~a: ~a~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((deploy-error? c)
+ (when (deploy-error-should-roll-back c)
+ (info (G_ "rolling back ~a...~%")
+ (machine-display-name machine))
+ (run-with-store store (roll-back-machine machine)))
+ (apply throw (deploy-error-captured-args c))))
+ (run-with-store store (deploy-machine machine))
+
+ (info (G_ "successfully deployed ~a~%")
+ (machine-display-name machine))))
+
+
(define (guix-deploy . args)
(define (handle-argument arg result)
(alist-cons 'file arg result))
@@ -129,21 +151,7 @@ Perform the deployment specified by FILE.\n"))
(set-build-options-from-command-line store opts)
(with-build-handler (build-notifier #:use-substitutes?
(assoc-ref opts 'substitutes?))
- (for-each (lambda (machine)
- (info (G_ "deploying to ~a...~%")
- (machine-display-name machine))
- (parameterize ((%graft? (assq-ref opts 'graft?)))
- (guard (c ((message-condition? c)
- (report-error (G_ "failed to deploy ~a: ~a~%")
- (machine-display-name machine)
- (condition-message c)))
- ((deploy-error? c)
- (when (deploy-error-should-roll-back c)
- (info (G_ "rolling back ~a...~%")
- (machine-display-name machine))
- (run-with-store store (roll-back-machine machine)))
- (apply throw (deploy-error-captured-args c))))
- (run-with-store store (deploy-machine machine))
- (info (G_ "successfully deployed ~a~%")
- (machine-display-name machine)))))
- machines))))))
+ (parameterize ((%graft? (assq-ref opts 'graft?)))
+ (map/accumulate-builds store
+ (cut deploy-machine* store <>)
+ machines)))))))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index e6f45d3eba..03f455ab7b 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -254,7 +254,7 @@ use '--preserve' instead~%"))
(alist-cons 'ad-hoc? #t result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 9d981c05d6..a4b38735a7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -823,7 +823,7 @@ last resort for relocation."
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\d "derivation") #f #f
(lambda (opt name arg result)
(alist-cons 'derivation-only? #t result)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 8af0a7a27e..304084796a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -487,8 +487,7 @@ kind of search path~%")
#f)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result arg-handler)
- (values (alist-cons 'dry-run? #t
- (alist-cons 'graft? #f result))
+ (values (alist-cons 'dry-run? #t result)
#f)))
(option '(#\v "verbosity") #t #f
(lambda (opt name arg result arg-handler)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index dbd02431fe..dfe7ee7ad5 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -168,7 +168,7 @@ Download and deploy the latest version of Guix.\n"))
(alist-delete 'system result eq?))))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\v "verbosity") #t #f
(lambda (opt name arg result)
(let ((level (string->number* arg)))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 61a3c95dbd..a178761203 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -1041,7 +1041,7 @@ Some ACTIONS support additional ARGS.\n"))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\v "verbosity") #t #f
(lambda (opt name arg result)
(let ((level (string->number* arg)))
diff --git a/guix/store.scm b/guix/store.scm
index 5dea264811..12f66d0e71 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -106,6 +106,8 @@
file-mapping->tree
binary-file
with-build-handler
+ map/accumulate-builds
+ mapm/accumulate-builds
build-things
build
query-failed-paths
@@ -134,6 +136,7 @@
built-in-builders
references
+ references/cached
references/substitutes
references*
query-path-info*
@@ -1303,6 +1306,48 @@ deals with \"dynamic dependencies\" such as grafts---derivations that depend
on the build output of a previous derivation."
(call-with-build-handler handler (lambda () exp ...)))
+;; Unresolved dynamic dependency.
+(define-record-type <unresolved>
+ (unresolved things continuation)
+ unresolved?
+ (things unresolved-things)
+ (continuation unresolved-continuation))
+
+(define (build-accumulator continue store things mode)
+ "This build handler accumulates THINGS and returns an <unresolved> object."
+ (if (= mode (build-mode normal))
+ (unresolved things continue)
+ (continue #t)))
+
+(define (map/accumulate-builds store proc lst)
+ "Apply PROC over each element of LST, accumulating 'build-things' calls and
+coalescing them into a single call."
+ (define result
+ (map (lambda (obj)
+ (with-build-handler build-accumulator
+ (proc obj)))
+ lst))
+
+ (match (append-map (lambda (obj)
+ (if (unresolved? obj)
+ (unresolved-things obj)
+ '()))
+ result)
+ (()
+ result)
+ (to-build
+ ;; We've accumulated things TO-BUILD. Actually build them and resume the
+ ;; corresponding continuations.
+ (build-things store (delete-duplicates to-build))
+ (map/accumulate-builds store
+ (lambda (obj)
+ (if (unresolved? obj)
+ ;; Pass #f because 'build-things' is now
+ ;; unnecessary.
+ ((unresolved-continuation obj) #f)
+ obj))
+ result))))
+
(define build-things
(let ((build (operation (build-things (string-list things)
(integer mode))
@@ -1389,6 +1434,13 @@ error if there is no such root."
;; would use a cache associated with the daemon connection instead (XXX).
(make-hash-table 100))
+(define (references/cached store item)
+ "Like 'references', but cache results."
+ (or (hash-ref %reference-cache item)
+ (let ((references (references store item)))
+ (hash-set! %reference-cache item references)
+ references)))
+
(define (references/substitutes store items)
"Return the list of list of references of ITEMS; the result has the same
length as ITEMS. Query substitute information for any item missing from the
@@ -1829,6 +1881,18 @@ taking the store as its first argument."
(lambda (store . args)
(run-with-store store (apply proc args)))))
+(define (mapm/accumulate-builds mproc lst)
+ "Like 'mapm' in %STORE-MONAD, but accumulate 'build-things' calls and
+coalesce them into a single call."
+ (lambda (store)
+ (values (map/accumulate-builds store
+ (lambda (obj)
+ (run-with-store store
+ (mproc obj)))
+ lst)
+ store)))
+
+
;;
;; Store monad operators.
;;