ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 13:49:23 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

packages: Call 'bag-grafts' only on the tip of the package graph.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2021-03-07 15:22:29 +01:00
parent e7477dd59b
commit 89b0c2390a
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 98 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

131
guix/packages.scm
View file

@ -1210,25 +1210,45 @@ (define-syntax cached
(#f (#f
(cache! cache package key thunk))))))) (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 "Expand INPUT, an input tuple, to a name/<gexp-input> tuple. PACKAGE is
only used to provide contextual information in exceptions." only used to provide contextual information in exceptions."
(match input (with-monad %store-monad
(((? string? name) (? file-like? thing)) (match input
(list name (gexp-input thing #:native? native?))) ;; INPUT doesn't need to be lowered here because it'll be lowered down
(((? string? name) (? file-like? thing) (? string? output)) ;; the road in the gexp that refers to it. However, packages need to be
(list name (gexp-input thing output #:native? native?))) ;; special-cased to pass #:graft? #f (only the "tip" of the package
(((? string? name) ;; graph needs to have #:graft? #t). Lowering them here also allows
(and (? string?) (? file-exists? file))) ;; 'bag->derivation' to delete non-eq? packages that lead to the same
;; Add FILE to the store. When FILE is in the sub-directory of a ;; derivation.
;; store path, it needs to be added anyway, so it can be used as a (((? string? name) (? package? package))
;; source. (mlet %store-monad ((drv (if target
(list name (gexp-input (local-file file #:recursive? #t) (package->cross-derivation package target
#:native? native?))) #:graft? #f)
(x (package->derivation package #:graft? #f))))
(raise (condition (&package-input-error (return (list name (gexp-input drv #:native? (not target))))))
(package package) (((? string? name) (? package? package) (? string? output))
(input x))))))) (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 (define %bag-cache
;; 'eq?' cache mapping packages to system+target+graft?-dependent bags. ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
@ -1438,17 +1458,18 @@ (define* (bag->derivation bag #:optional context)
error reporting." error reporting."
(if (bag-target bag) (if (bag-target bag)
(bag->cross-derivation bag) (bag->cross-derivation bag)
(let* ((system (bag-system bag)) (mlet* %store-monad ((system -> (bag-system bag))
(inputs (bag-transitive-inputs bag)) (inputs -> (bag-transitive-inputs bag))
(input-drvs (map (cut expand-input context <> #:native? #t) (input-drvs (mapm %store-monad
inputs)) (cut expand-input context <>)
(paths (delete-duplicates inputs))
(append-map (match-lambda (paths -> (delete-duplicates
((_ (? package? p) _ ...) (append-map (match-lambda
(package-native-search-paths ((_ (? package? p) _ ...)
p)) (package-native-search-paths
(_ '())) p))
inputs)))) (_ '()))
inputs))))
;; It's possible that INPUTS contains packages that are not 'eq?' but ;; It's possible that INPUTS contains packages that are not 'eq?' but
;; that lead to the same derivation. Delete those duplicates to avoid ;; that lead to the same derivation. Delete those duplicates to avoid
;; issues down the road, such as duplicate entries in '%build-inputs'. ;; issues down the road, such as duplicate entries in '%build-inputs'.
@ -1462,31 +1483,35 @@ (define* (bag->cross-derivation bag #:optional context)
"Return the derivation to build BAG, which is actually a cross build. "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. Optionally, CONTEXT can be a package object denoting the context of the call.
This is an internal procedure." This is an internal procedure."
(let* ((system (bag-system bag)) (mlet* %store-monad ((system -> (bag-system bag))
(target (bag-target bag)) (target -> (bag-target bag))
(host (bag-transitive-host-inputs bag)) (host -> (bag-transitive-host-inputs bag))
(host-drvs (map (cut expand-input context <> #:native? #f) (host-drvs (mapm %store-monad
host)) (cut expand-input context <>
(target* (bag-transitive-target-inputs bag)) #:target target)
(target-drvs (map (cut expand-input context <> #:native? #t) host))
target*)) (target* -> (bag-transitive-target-inputs bag))
(build (bag-transitive-build-inputs bag)) (target-drvs (mapm %store-monad
(build-drvs (map (cut expand-input context <> #:native? #t) (cut expand-input context <>)
build)) target*))
(all (append build target* host)) (build -> (bag-transitive-build-inputs bag))
(paths (delete-duplicates (build-drvs (mapm %store-monad
(append-map (match-lambda (cut expand-input context <>)
((_ (? package? p) _ ...) build))
(package-search-paths p)) (all -> (append build target* host))
(_ '())) (paths -> (delete-duplicates
all))) (append-map (match-lambda
(npaths (delete-duplicates ((_ (? package? p) _ ...)
(append-map (match-lambda (package-search-paths p))
((_ (? package? p) _ ...) (_ '()))
(package-native-search-paths all)))
p)) (npaths -> (delete-duplicates
(_ '())) (append-map (match-lambda
all)))) ((_ (? package? p) _ ...)
(package-native-search-paths
p))
(_ '()))
all))))
(apply (bag-build bag) (bag-name bag) (apply (bag-build bag) (bag-name bag)
#:build-inputs (delete-duplicates build-drvs input=?) #:build-inputs (delete-duplicates build-drvs input=?)

34
tests/packages.scm
View file

@ -858,19 +858,23 @@ (define compressors '(("gzip" . "gz")
(test-assert "search paths" (test-assert "search paths"
(let* ((p (make-prompt-tag "return-search-paths")) (let* ((p (make-prompt-tag "return-search-paths"))
(t (make-parameter "guile-0"))
(s (build-system (s (build-system
(name 'raw) (name 'raw)
(description "Raw build system with direct store access") (description "Raw build system with direct store access")
(lower (lambda* (name #:key source inputs system target (lower (lambda* (name #:key source inputs system target
#:allow-other-keys) #:allow-other-keys)
(bag (bag
(name name) (name name)
(system system) (target target) (system system) (target target)
(build-inputs inputs) (build-inputs inputs)
(build (build
(lambda* (name inputs (lambda* (name inputs
#:key outputs system search-paths) #:key outputs system search-paths)
(abort-to-prompt p search-paths)))))))) (if (string=? name (t))
(abort-to-prompt p search-paths)
(gexp->derivation name
#~(mkdir #$output))))))))))
(x (list (search-path-specification (x (list (search-path-specification
(variable "GUILE_LOAD_PATH") (variable "GUILE_LOAD_PATH")
(files '("share/guile/site/2.0"))) (files '("share/guile/site/2.0")))
@ -895,8 +899,10 @@ (define compressors '(("gzip" . "gz")
(lambda (k search-paths) (lambda (k search-paths)
search-paths)))))) search-paths))))))
(and (null? (collect (package-derivation %store a))) (and (null? (collect (package-derivation %store a)))
(equal? x (collect (package-derivation %store b))) (parameterize ((t "guile-foo-0"))
(equal? x (collect (package-derivation %store c))))))) (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" (test-assert "package-transitive-native-search-paths"
(let* ((sp (lambda (name) (let* ((sp (lambda (name)