mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-01-31 06:46:50 +01:00
grafts: Only compute necessary graft derivations.
* guix/packages.scm (input-graft, input-cross-graft): Store the monadic value
of the replacement in the 'replacement' field of <graft> instead of unwrapping
it.
(cumulative-grafts): Turn monadic values in the 'replacement' field of
applicable grafts into derivations.
* tests/packages.scm ("package-grafts, indirect grafts")
("package-grafts, indirect grafts, propagated inputs")
("package-grafts, same replacement twice")
("package-grafts, dependency on several outputs")
("replacement also grafted"): Do not compare <graft> records directly,
compare the relevant fields instead, calling ‘run-with-store’ on the
‘replacement’ field.
Co-authored-by: Ludovic Courtès <ludo@gnu.org>
Change-Id: Idded0a402b8974df1ef2354f1a88c308b9b99777
This commit is contained in:
David Elsing
Ludovic Courtès
parent
c69f366527
commit
3331d675fb
3 changed files with 80 additions and 42 deletions
|
|
@ -1,5 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -53,7 +54,7 @@ (define-record-type* <graft> graft make-graft
|
|||
(origin graft-origin) ;derivation | store item
|
||||
(origin-output graft-origin-output ;string | #f
|
||||
(default "out"))
|
||||
(replacement graft-replacement) ;derivation | store item
|
||||
(replacement graft-replacement) ;derivation | store item | monadic
|
||||
(replacement-output graft-replacement-output ;string | #f
|
||||
(default "out")))
|
||||
|
||||
|
|
@ -274,6 +275,20 @@ (define (dependency-grafts items)
|
|||
#:system system)))))
|
||||
(reference-origins drv items)))
|
||||
|
||||
;; If the 'replacement' field of the <graft> record is a procedure,
|
||||
;; this means that it is a value in the store monad and the actual
|
||||
;; derivation needs to be computed here.
|
||||
(define (finalize-graft item)
|
||||
(let ((replacement (graft-replacement item)))
|
||||
(if (procedure? replacement)
|
||||
(graft
|
||||
(inherit item)
|
||||
(replacement
|
||||
(run-with-store store replacement
|
||||
#:guile-for-build guile
|
||||
#:system system)))
|
||||
item)))
|
||||
|
||||
(with-cache (list (derivation-file-name drv) outputs grafts)
|
||||
(match (non-self-references store drv outputs)
|
||||
(() ;no dependencies
|
||||
|
|
@ -290,7 +305,8 @@ (define (dependency-grafts items)
|
|||
;; Use APPLICABLE, the subset of GRAFTS that is really
|
||||
;; applicable to DRV, to avoid creating several identical
|
||||
;; grafted variants of DRV.
|
||||
(let* ((new (graft-derivation/shallow* store drv applicable
|
||||
(let* ((new (graft-derivation/shallow* store drv
|
||||
(map finalize-graft applicable)
|
||||
#:outputs outputs
|
||||
#:guile guile
|
||||
#:system system))
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@
|
|||
;;; Copyright © 2022 jgart <jgart@dismail.de>
|
||||
;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
|
||||
;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -1818,8 +1819,10 @@ (define (input-graft system)
|
|||
(mcached eq? (=> %package-graft-cache)
|
||||
(mlet %store-monad ((orig (package->derivation package system
|
||||
#:graft? #f))
|
||||
(new (package->derivation replacement system
|
||||
#:graft? #t)))
|
||||
(new -> (package->derivation replacement system
|
||||
#:graft? #t)))
|
||||
;; Keep NEW as a monadic value so that its computation
|
||||
;; is delayed until necessary.
|
||||
(return (graft
|
||||
(origin orig)
|
||||
(origin-output output)
|
||||
|
|
@ -1840,9 +1843,11 @@ (define (input-cross-graft target system)
|
|||
(mlet %store-monad ((orig (package->cross-derivation package
|
||||
target system
|
||||
#:graft? #f))
|
||||
(new (package->cross-derivation replacement
|
||||
target system
|
||||
#:graft? #t)))
|
||||
(new -> (package->cross-derivation replacement
|
||||
target system
|
||||
#:graft? #t)))
|
||||
;; Keep NEW as a monadic value so that its computation
|
||||
;; is delayed until necessary.
|
||||
(return (graft
|
||||
(origin orig)
|
||||
(origin-output output)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
|
||||
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
|
||||
|
|
@ -1091,10 +1091,13 @@ (define right-system?
|
|||
(dummy (dummy-package "dummy"
|
||||
(arguments '(#:implicit-inputs? #f))
|
||||
(inputs (list dep*)))))
|
||||
(equal? (package-grafts %store dummy)
|
||||
(list (graft
|
||||
(origin (package-derivation %store dep))
|
||||
(replacement (package-derivation %store new)))))))
|
||||
(match (package-grafts %store dummy)
|
||||
((graft)
|
||||
(and (eq? (graft-origin graft)
|
||||
(package-derivation %store dep))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
|
||||
;; XXX: This test would require building the cross toolchain just to see if it
|
||||
;; needs grafting, which is obviously too expensive, and thus disabled.
|
||||
|
|
@ -1127,10 +1130,13 @@ (define right-system?
|
|||
(dummy (dummy-package "dummy"
|
||||
(arguments '(#:implicit-inputs? #f))
|
||||
(inputs (list prop)))))
|
||||
(equal? (package-grafts %store dummy)
|
||||
(list (graft
|
||||
(origin (package-derivation %store dep))
|
||||
(replacement (package-derivation %store new)))))))
|
||||
(match (package-grafts %store dummy)
|
||||
((graft)
|
||||
(and (eq? (graft-origin graft)
|
||||
(package-derivation %store dep))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
|
||||
(test-assert "package-grafts, same replacement twice"
|
||||
(let* ((new (dummy-package "dep"
|
||||
|
|
@ -1149,12 +1155,15 @@ (define right-system?
|
|||
(p3 (dummy-package "final"
|
||||
(arguments '(#:implicit-inputs? #f))
|
||||
(inputs (list p1 p2)))))
|
||||
(equal? (package-grafts %store p3)
|
||||
(list (graft
|
||||
(origin (package-derivation %store
|
||||
(package (inherit dep)
|
||||
(replacement #f))))
|
||||
(replacement (package-derivation %store new)))))))
|
||||
(match (package-grafts %store p3)
|
||||
((graft)
|
||||
(and (eq? (graft-origin graft)
|
||||
(package-derivation %store
|
||||
(package (inherit dep)
|
||||
(replacement #f))))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft))
|
||||
(package-derivation %store new)))))))
|
||||
|
||||
(test-assert "package-grafts, dependency on several outputs"
|
||||
;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
|
||||
|
|
@ -1167,17 +1176,22 @@ (define right-system?
|
|||
(p1 (dummy-package "p1"
|
||||
(arguments '(#:implicit-inputs? #f))
|
||||
(inputs (list p0 `(,p0 "lib"))))))
|
||||
(lset= equal? (pk (package-grafts %store p1))
|
||||
(list (graft
|
||||
(origin (package-derivation %store p0))
|
||||
(origin-output "out")
|
||||
(replacement (package-derivation %store p0*))
|
||||
(replacement-output "out"))
|
||||
(graft
|
||||
(origin (package-derivation %store p0))
|
||||
(origin-output "lib")
|
||||
(replacement (package-derivation %store p0*))
|
||||
(replacement-output "lib"))))))
|
||||
(match (sort (package-grafts %store p1)
|
||||
(lambda (graft1 graft2)
|
||||
(string<? (graft-origin-output graft1)
|
||||
(graft-origin-output graft2))))
|
||||
((graft1 graft2)
|
||||
(and (eq? (graft-origin graft1) (graft-origin graft2)
|
||||
(package-derivation %store p0))
|
||||
(eq? (run-with-store %store (graft-replacement graft1))
|
||||
(run-with-store %store (graft-replacement graft2))
|
||||
(package-derivation %store p0*))
|
||||
(string=? "lib"
|
||||
(graft-origin-output graft1)
|
||||
(graft-replacement-output graft1))
|
||||
(string=? "out"
|
||||
(graft-origin-output graft2)
|
||||
(graft-replacement-output graft2)))))))
|
||||
|
||||
(test-assert "replacement also grafted"
|
||||
;; We build a DAG as below, where dotted arrows represent replacements and
|
||||
|
|
@ -1244,15 +1258,18 @@ (define right-system?
|
|||
(symlink (assoc-ref %build-inputs "p2")
|
||||
"p2")
|
||||
#t))))))
|
||||
(lset= equal?
|
||||
(package-grafts %store p3)
|
||||
(list (graft
|
||||
(origin (package-derivation %store p1 #:graft? #f))
|
||||
(replacement (package-derivation %store p1r)))
|
||||
(graft
|
||||
(origin (package-derivation %store p2 #:graft? #f))
|
||||
(replacement
|
||||
(package-derivation %store p2r #:graft? #t)))))))
|
||||
(match (package-grafts %store p3)
|
||||
((graft1 graft2)
|
||||
(and (eq? (graft-origin graft1)
|
||||
(package-derivation %store p1 #:graft? #f))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft1))
|
||||
(package-derivation %store p1r))
|
||||
(eq? (graft-origin graft2)
|
||||
(package-derivation %store p2 #:graft? #f))
|
||||
(eq? (run-with-store %store
|
||||
(graft-replacement graft2))
|
||||
(package-derivation %store p2r #:graft? #t)))))))
|
||||
|
||||
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
|
||||
;;; find out about their run-time dependencies, so this test is no longer
|
||||
|
|
|
|||
Loading…
Reference in a new issue