packages: 'package-grafts' trims native inputs.

'package-grafts' returns a list of potentially applicable grafts, which
'cumulative-grafts' then narrows by looking at store item references and
determining the subset of the grafts that's actually applicable.

Until now, 'package-grafts' would traverse native inputs and would thus
return a large superset of the applicable grafts, since native inputs
are not in the reference graph by definition.  This patch fixes that by
having 'package-grafts' ignore entirely native inputs from the
dependency graph.

* guix/packages.scm (fold-bag-dependencies)[bag-direct-inputs*]: Add
special case for libc.
* guix/packages.scm (bag-grafts)[native-grafts, target-grafts]: Remove.
[grafts]: New procedure.
Use it.
* tests/packages.scm ("package-grafts, grafts of native inputs
ignored"): New test.
This commit is contained in:
Ludovic Courtès 2017-12-05 16:32:40 +01:00
parent f3e3f4d934
commit 91c9b5d016
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 48 additions and 21 deletions

View File

@ -1004,7 +1004,21 @@ dependencies; otherwise, restrict to target dependencies."
(if (bag-target bag)
'()
(bag-host-inputs bag))))
bag-host-inputs))
(lambda (bag)
(if (bag-target bag)
(bag-host-inputs bag)
;; XXX: Currently libc wrongfully ends up in 'build-inputs',
;; even tough it's something that's still referenced at run time
;; and thus conceptually a 'host-inputs'. Because of that, we
;; re-add it here.
(if (assoc-ref (bag-host-inputs bag) "libc")
(bag-host-inputs bag)
(append (let ((libc (assoc-ref (bag-build-inputs bag)
"libc")))
(or (and libc `(("libc" ,@libc)))
'()))
(bag-host-inputs bag)))))))
(define nodes
(match (bag-direct-inputs* bag)
@ -1038,33 +1052,28 @@ to (see 'graft-derivation'.)"
(define system (bag-system bag))
(define target (bag-target bag))
(define native-grafts
(let ((->graft (input-graft store system)))
(define (grafts package->graft)
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag)))
(define target-grafts
(if target
(let ((->graft (input-cross-graft store target system)))
(fold-bag-dependencies (lambda (package grafts)
(match (->graft package)
(match (package->graft package)
(#f grafts)
(graft (cons graft grafts))))
'()
bag
;; Grafts that apply to native inputs do not matter
;; since, by definition, native inputs are not
;; referred to at run time. Thus, ignore
;; 'native-inputs' and focus on the others.
#:native? #f))
'()))
;; We can end up with several identical grafts if we stumble upon packages
;; that are not 'eq?' but map to the same derivation (this can happen when
;; using things like 'package-with-explicit-inputs'.) Hence the
;; 'delete-duplicates' call.
(delete-duplicates
(append native-grafts target-grafts)))
(if target
(grafts (input-cross-graft store target system))
(grafts (input-graft store system)))))
(define* (package-grafts store package
#:optional (system (%current-system))

View File

@ -660,6 +660,24 @@
;; (package-cross-derivation %store p "mips64el-linux-gnu"
;; #:graft? #t)))
;; It doesn't make sense for 'package-grafts' to look at native inputs since,
;; by definition, they are not referenced at run time. Make sure
;; 'package-grafts' respects this.
(test-equal "package-grafts, grafts of native inputs ignored"
'()
(let* ((new (dummy-package "native-dep"
(version "0.1")
(arguments '(#:implicit-inputs? #f))))
(ndep (package (inherit new) (version "0.0")
(replacement new)))
(dep (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))
(dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f))
(native-inputs `(("ndep" ,ndep)))
(inputs `(("dep" ,dep))))))
(package-grafts %store dummy)))
(test-assert "package-grafts, indirect grafts"
(let* ((new (dummy-package "dep"
(arguments '(#:implicit-inputs? #f))))