[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
13/17: packages: Call 'bag-grafts' only on the tip of the package graph.
|
From: |
guix-commits |
|
Subject: |
13/17: packages: Call 'bag-grafts' only on the tip of the package graph. |
|
Date: |
Mon, 22 Mar 2021 18:02:39 -0400 (EDT) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 31d5e7d3abb188337535ee09aa3eee5c1e710389
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Mar 7 15:22:29 2021 +0100
packages: Call 'bag-grafts' only on the tip of the package graph.
This reinstates pre-gexp behavior where 'expand-input' would explicitly
pass #:graft? #f in recursive calls, thereby preventing redundant calls
to 'bag-grafts'.
* guix/packages.scm (expand-input): Turn into a monadic procedure.
Lower INPUT when it's a package, passing #:graft? #f.
(bag->derivation, bag->cross-derivation): Adjust accordingly.
* tests/packages.scm ("search paths"): Adjust so BUILD aborts only when
passed the package of interest.
---
guix/packages.scm | 131 +++++++++++++++++++++++++++++++----------------------
tests/packages.scm | 34 ++++++++------
2 files changed, 98 insertions(+), 67 deletions(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 34f3ec4..d1e9116 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1208,25 +1208,45 @@ Return the cached result when available."
(#f
(cache! cache package key thunk)))))))
-(define* (expand-input package input #:key native?)
+(define* (expand-input package input #:key target)
"Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
only used to provide contextual information in exceptions."
- (match input
- (((? string? name) (? file-like? thing))
- (list name (gexp-input thing #:native? native?)))
- (((? string? name) (? file-like? thing) (? string? output))
- (list name (gexp-input thing output #:native? native?)))
- (((? string? name)
- (and (? string?) (? file-exists? file)))
- ;; Add FILE to the store. When FILE is in the sub-directory of a
- ;; store path, it needs to be added anyway, so it can be used as a
- ;; source.
- (list name (gexp-input (local-file file #:recursive? #t)
- #:native? native?)))
- (x
- (raise (condition (&package-input-error
- (package package)
- (input x)))))))
+ (with-monad %store-monad
+ (match input
+ ;; INPUT doesn't need to be lowered here because it'll be lowered down
+ ;; the road in the gexp that refers to it. However, packages need to be
+ ;; special-cased to pass #:graft? #f (only the "tip" of the package
+ ;; graph needs to have #:graft? #t). Lowering them here also allows
+ ;; 'bag->derivation' to delete non-eq? packages that lead to the same
+ ;; derivation.
+ (((? string? name) (? package? package))
+ (mlet %store-monad ((drv (if target
+ (package->cross-derivation package target
+ #:graft? #f)
+ (package->derivation package #:graft?
#f))))
+ (return (list name (gexp-input drv #:native? (not target))))))
+ (((? string? name) (? package? package) (? string? output))
+ (mlet %store-monad ((drv (if target
+ (package->cross-derivation package target
+ #:graft? #f)
+ (package->derivation package #:graft?
#f))))
+ (return (list name (gexp-input drv output #:native? (not target))))))
+
+ (((? string? name) (? file-like? thing))
+ (return (list name (gexp-input thing #:native? (not target)))))
+ (((? string? name) (? file-like? thing) (? string? output))
+ (return (list name (gexp-input thing output #:native? (not target)))))
+ (((? string? name)
+ (and (? string?) (? file-exists? file)))
+ ;; Add FILE to the store. When FILE is in the sub-directory of a
+ ;; store path, it needs to be added anyway, so it can be used as a
+ ;; source.
+ (return (list name (gexp-input (local-file file #:recursive? #t)
+ #:native? (not target)))))
+ (x
+ (raise (condition (&package-input-error
+ (package package)
+ (input x))))))))
(define %bag-cache
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
@@ -1436,17 +1456,18 @@ a package object describing the context in which the
call occurs, for improved
error reporting."
(if (bag-target bag)
(bag->cross-derivation bag)
- (let* ((system (bag-system bag))
- (inputs (bag-transitive-inputs bag))
- (input-drvs (map (cut expand-input context <> #:native? #t)
- inputs))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- inputs))))
+ (mlet* %store-monad ((system -> (bag-system bag))
+ (inputs -> (bag-transitive-inputs bag))
+ (input-drvs (mapm %store-monad
+ (cut expand-input context <>)
+ inputs))
+ (paths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+
(package-native-search-paths
+ p))
+ (_ '()))
+ inputs))))
;; It's possible that INPUTS contains packages that are not 'eq?' but
;; that lead to the same derivation. Delete those duplicates to avoid
;; issues down the road, such as duplicate entries in '%build-inputs'.
@@ -1460,31 +1481,35 @@ error reporting."
"Return the derivation to build BAG, which is actually a cross build.
Optionally, CONTEXT can be a package object denoting the context of the call.
This is an internal procedure."
- (let* ((system (bag-system bag))
- (target (bag-target bag))
- (host (bag-transitive-host-inputs bag))
- (host-drvs (map (cut expand-input context <> #:native? #f)
- host))
- (target* (bag-transitive-target-inputs bag))
- (target-drvs (map (cut expand-input context <> #:native? #t)
- target*))
- (build (bag-transitive-build-inputs bag))
- (build-drvs (map (cut expand-input context <> #:native? #t)
- build))
- (all (append build target* host))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-search-paths p))
- (_ '()))
- all)))
- (npaths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- all))))
+ (mlet* %store-monad ((system -> (bag-system bag))
+ (target -> (bag-target bag))
+ (host -> (bag-transitive-host-inputs bag))
+ (host-drvs (mapm %store-monad
+ (cut expand-input context <>
+ #:target target)
+ host))
+ (target* -> (bag-transitive-target-inputs bag))
+ (target-drvs (mapm %store-monad
+ (cut expand-input context <>)
+ target*))
+ (build -> (bag-transitive-build-inputs bag))
+ (build-drvs (mapm %store-monad
+ (cut expand-input context <>)
+ build))
+ (all -> (append build target* host))
+ (paths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+ (package-search-paths p))
+ (_ '()))
+ all)))
+ (npaths -> (delete-duplicates
+ (append-map (match-lambda
+ ((_ (? package? p) _ ...)
+
(package-native-search-paths
+ p))
+ (_ '()))
+ all))))
(apply (bag-build bag) (bag-name bag)
#:build-inputs (delete-duplicates build-drvs input=?)
diff --git a/tests/packages.scm b/tests/packages.scm
index 97c4c17..47d10af 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -858,19 +858,23 @@
(test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths"))
+ (t (make-parameter "guile-0"))
(s (build-system
- (name 'raw)
- (description "Raw build system with direct store access")
- (lower (lambda* (name #:key source inputs system target
- #:allow-other-keys)
- (bag
- (name name)
- (system system) (target target)
- (build-inputs inputs)
- (build
- (lambda* (name inputs
- #:key outputs system search-paths)
- (abort-to-prompt p search-paths))))))))
+ (name 'raw)
+ (description "Raw build system with direct store access")
+ (lower (lambda* (name #:key source inputs system target
+ #:allow-other-keys)
+ (bag
+ (name name)
+ (system system) (target target)
+ (build-inputs inputs)
+ (build
+ (lambda* (name inputs
+ #:key outputs system search-paths)
+ (if (string=? name (t))
+ (abort-to-prompt p search-paths)
+ (gexp->derivation name
+ #~(mkdir #$output))))))))))
(x (list (search-path-specification
(variable "GUILE_LOAD_PATH")
(files '("share/guile/site/2.0")))
@@ -895,8 +899,10 @@
(lambda (k search-paths)
search-paths))))))
(and (null? (collect (package-derivation %store a)))
- (equal? x (collect (package-derivation %store b)))
- (equal? x (collect (package-derivation %store c)))))))
+ (parameterize ((t "guile-foo-0"))
+ (equal? x (collect (package-derivation %store b))))
+ (parameterize ((t "guile-bar-0"))
+ (equal? x (collect (package-derivation %store c))))))))
(test-assert "package-transitive-native-search-paths"
(let* ((sp (lambda (name)
- branch wip-build-systems-gexp created (now 082df93), guix-commits, 2021/03/22
- 01/17: gexp: Add 'with-build-variables'., guix-commits, 2021/03/22
- 03/17: build-system: Rewrite using gexps., guix-commits, 2021/03/22
- 04/17: packages: Turn 'bag->derivation' into a monadic procedure., guix-commits, 2021/03/22
- 05/17: packages: Simplify patch instantiation., guix-commits, 2021/03/22
- 02/17: gexp: Optimize 'with-build-variables'., guix-commits, 2021/03/22
- 07/17: packages: Default origin 'patch-flags' is a gexp., guix-commits, 2021/03/22
- 12/17: packages: 'expand-input' accepts any file-like object., guix-commits, 2021/03/22
- 13/17: packages: Call 'bag-grafts' only on the tip of the package graph.,
guix-commits <=
- 06/17: packages: Core procedures are written in monadic style., guix-commits, 2021/03/22
- 08/17: gexp: Add 'sexp->gexp'., guix-commits, 2021/03/22
- 16/17: gexp: Do not add derivations to the object cache., guix-commits, 2021/03/22
- 17/17: gnu: docbook-xsl: Move 'use-modules' form to the top level., guix-commits, 2021/03/22
- 10/17: build-system: Use 'input-tuples->gexp' and 'outputs->gexp'., guix-commits, 2021/03/22
- 09/17: build-system: Use 'sexp->gexp' for plain sexps., guix-commits, 2021/03/22
- 11/17: packages: '%standard-patch-inputs' is not influenced by '%current-target-system'., guix-commits, 2021/03/22
- 15/17: gexp: Allowed/disallowed references and graphs never refer to grafted inputs., guix-commits, 2021/03/22
- 14/17: grafts: Add 'without-grafting'., guix-commits, 2021/03/22