From ff0e0041f358c0e4d0ab890f183b8a0c31727bea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Dec 2017 15:13:38 +0100 Subject: packages: 'fold-bag-dependencies' honors nativeness in recursive calls. Previously recursive calls to 'loop' would always consider all the bag inputs rather than those corresponding to NATIVE?. * guix/packages.scm (fold-bag-dependencies)[bag-direct-inputs*]: New procedure. Use it both in the 'match' expression and in its body. --- guix/packages.scm | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) (limited to 'guix/packages.scm') diff --git a/guix/packages.scm b/guix/packages.scm index d68af1569f..c6d3b811f2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -996,14 +996,18 @@ and return it." "Fold PROC over the packages BAG depends on. Each package is visited only once, in depth-first order. If NATIVE? is true, restrict to native dependencies; otherwise, restrict to target dependencies." + (define bag-direct-inputs* + (if native? + (lambda (bag) + (append (bag-build-inputs bag) + (bag-target-inputs bag) + (if (bag-target bag) + '() + (bag-host-inputs bag)))) + bag-host-inputs)) + (define nodes - (match (if native? - (append (bag-build-inputs bag) - (bag-target-inputs bag) - (if (bag-target bag) - '() - (bag-host-inputs bag))) - (bag-host-inputs bag)) + (match (bag-direct-inputs* bag) (((labels things _ ...) ...) things))) @@ -1016,7 +1020,7 @@ dependencies; otherwise, restrict to target dependencies." (((? package? head) . tail) (if (set-contains? visited head) (loop tail result visited) - (let ((inputs (bag-direct-inputs (package->bag head)))) + (let ((inputs (bag-direct-inputs* (package->bag head)))) (loop (match inputs (((labels things _ ...) ...) (append things tail))) -- cgit v1.2.3 From 91c9b5d016ac8bed127557d378c70fbc56cec0e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Dec 2017 16:32:40 +0100 Subject: 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. --- guix/packages.scm | 53 +++++++++++++++++++++++++++++++---------------------- tests/packages.scm | 18 ++++++++++++++++++ 2 files changed, 49 insertions(+), 22 deletions(-) (limited to 'guix/packages.scm') diff --git a/guix/packages.scm b/guix/packages.scm index c6d3b811f2..490ec86906 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -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))) - (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) - (#f grafts) - (graft (cons graft grafts)))) - '() - bag - #:native? #f)) - '())) + (define (grafts package->graft) + (fold-bag-dependencies (lambda (package grafts) + (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)) diff --git a/tests/packages.scm b/tests/packages.scm index 930374dabf..fe7bd1ded6 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -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)))) -- cgit v1.2.3 From 609d126e86ea7a05ab7e758fa3fd000ced005f49 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Dec 2017 09:07:28 +0100 Subject: Revert "packages: 'package-grafts' trims native inputs." This reverts commit 91c9b5d016ac8bed127557d378c70fbc56cec0e5 following the concerns raised by Mark, Ben, and Tobias: . --- guix/packages.scm | 53 ++++++++++++++++++++++------------------------------- tests/packages.scm | 18 ------------------ 2 files changed, 22 insertions(+), 49 deletions(-) (limited to 'guix/packages.scm') diff --git a/guix/packages.scm b/guix/packages.scm index 490ec86906..c6d3b811f2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1004,21 +1004,7 @@ dependencies; otherwise, restrict to target dependencies." (if (bag-target bag) '() (bag-host-inputs bag)))) - (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))))))) + bag-host-inputs)) (define nodes (match (bag-direct-inputs* bag) @@ -1052,28 +1038,33 @@ to (see 'graft-derivation'.)" (define system (bag-system bag)) (define target (bag-target bag)) - (define (grafts package->graft) - (fold-bag-dependencies (lambda (package grafts) - (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)) + (define native-grafts + (let ((->graft (input-graft store system))) + (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) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag + #: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 - (if target - (grafts (input-cross-graft store target system)) - (grafts (input-graft store system))))) + (append native-grafts target-grafts))) (define* (package-grafts store package #:optional (system (%current-system)) diff --git a/tests/packages.scm b/tests/packages.scm index fe7bd1ded6..930374dabf 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -660,24 +660,6 @@ ;; (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)))) -- cgit v1.2.3