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: Delete duplicate inputs when lowering bags.

Browse source 
This is a followup to 18fa433bf5 and
<https://issues.guix.gnu.org/43508>.

* guix/packages.scm (derivation=?, input=?): New procedures.
(bag->derivation, bag->cross-derivation): Add calls to
'delete-duplicates'.
* tests/packages.scm ("package-derivation, inputs deduplicated"): New
test.
This commit is contained in:
Ludovic Courtès 2020-10-15 23:01:57 +02:00
parent 370adc91b5
commit 6b4663363c
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 37 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
guix/packages.scm
View file

@ -1322,6 +1322,22 @@ (define* (package-grafts store package
(bag (package->bag package system target))) (bag (package->bag package system target)))
(bag-grafts store bag))) (bag-grafts store bag)))
(define-inlinable (derivation=? drv1 drv2)
"Return true if DRV1 and DRV2 are equal."
(or (eq? drv1 drv2)
(string=? (derivation-file-name drv1)
(derivation-file-name drv2))))
(define (input=? input1 input2)
"Return true if INPUT1 and INPUT2 are equivalent."
(match input1
((label1 drv1 . outputs1)
(match input2
((label2 drv2 . outputs2)
(and (string=? label1 label2)
(equal? outputs1 outputs2)
(derivation=? drv1 drv2)))))))
(define* (bag->derivation store bag (define* (bag->derivation store bag
#:optional context) #:optional context)
"Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
@ -1340,9 +1356,12 @@ (define* (bag->derivation store bag
p)) p))
(_ '())) (_ '()))
inputs)))) 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'.
(apply (bag-build bag) (apply (bag-build bag)
store (bag-name bag) input-drvs store (bag-name bag)
(delete-duplicates input-drvs input=?)
#:search-paths paths #:search-paths paths
#:outputs (bag-outputs bag) #:system system #:outputs (bag-outputs bag) #:system system
(bag-arguments bag))))) (bag-arguments bag)))))
@ -1380,8 +1399,9 @@ (define* (bag->cross-derivation store bag
(apply (bag-build bag) (apply (bag-build bag)
store (bag-name bag) store (bag-name bag)
#:native-drvs build-drvs #:native-drvs (delete-duplicates build-drvs input=?)
#:target-drvs (append host-drvs target-drvs) #:target-drvs (delete-duplicates (append host-drvs target-drvs)
input=?)
#:search-paths paths #:search-paths paths
#:native-search-paths npaths #:native-search-paths npaths
#:outputs (bag-outputs bag) #:outputs (bag-outputs bag)

13
tests/packages.scm
View file

@ -611,6 +611,19 @@ (define read-at
(and (derivation? drv) (and (derivation? drv)
(file-exists? (derivation-file-name drv))))) (file-exists? (derivation-file-name drv)))))
(test-assert "package-derivation, inputs deduplicated"
(let* ((dep (dummy-package "dep"))
(p0 (dummy-package "p" (inputs `(("dep" ,dep)))))
(p1 (package (inherit p0)
(inputs `(("dep" ,(package (inherit dep)))
,@(package-inputs p0))))))
;; Here P1 ends up with two non-eq? copies of DEP, under the same label.
;; They should be deduplicated so that P0 and P1 lead to the same
;; derivation rather than P1 ending up with duplicate entries in its
;; '%build-inputs' variable.
(string=? (derivation-file-name (package-derivation %store p0))
(derivation-file-name (package-derivation %store p1)))))
(test-assert "package-output" (test-assert "package-output"
(let* ((package (dummy-package "p")) (let* ((package (dummy-package "p"))
(drv (package-derivation %store package))) (drv (package-derivation %store package)))