amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

grafts: Only compute necessary graft derivations.

Browse source 
* 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 2024-06-05 21:51:42 +00:00 • committed by Ludovic Courtès
parent c69f366527
commit 3331d675fb
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 80 additions and 42 deletions
Download patch file Download diff file Expand all files Collapse all files

20
guix/grafts.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -53,7 +54,7 @@
(origin graft-origin) ;derivation | store item (origin graft-origin) ;derivation | store item
(origin-output graft-origin-output ;string | #f (origin-output graft-origin-output ;string | #f
(default "out")) (default "out"))
(replacement graft-replacement) ;derivation | store item (replacement graft-replacement) ;derivation | store item | monadic
(replacement-output graft-replacement-output ;string | #f (replacement-output graft-replacement-output ;string | #f
(default "out"))) (default "out")))
@ -274,6 +275,20 @@ derivations to the corresponding set of grafts."
#:system system))))) #:system system)))))
(reference-origins drv items))) (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) (with-cache (list (derivation-file-name drv) outputs grafts)
(match (non-self-references store drv outputs) (match (non-self-references store drv outputs)
(() ;no dependencies (() ;no dependencies
@ -290,7 +305,8 @@ derivations to the corresponding set of grafts."
;; Use APPLICABLE, the subset of GRAFTS that is really ;; Use APPLICABLE, the subset of GRAFTS that is really
;; applicable to DRV, to avoid creating several identical ;; applicable to DRV, to avoid creating several identical
;; grafted variants of DRV. ;; 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 #:outputs outputs
#:guile guile #:guile guile
#:system system)) #:system system))

9
guix/packages.scm
View file

@ -11,6 +11,7 @@
;;; Copyright © 2022 jgart <jgart@dismail.de> ;;; Copyright © 2022 jgart <jgart@dismail.de>
;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -1818,8 +1819,10 @@ graft, and #f otherwise."
(mcached eq? (=> %package-graft-cache) (mcached eq? (=> %package-graft-cache)
(mlet %store-monad ((orig (package->derivation package system (mlet %store-monad ((orig (package->derivation package system
#:graft? #f)) #:graft? #f))
(new (package->derivation replacement system (new -> (package->derivation replacement system
#:graft? #t))) #:graft? #t)))
;; Keep NEW as a monadic value so that its computation
;; is delayed until necessary.
(return (graft (return (graft
(origin orig) (origin orig)
(origin-output output) (origin-output output)
@ -1840,9 +1843,11 @@ graft, and #f otherwise."
(mlet %store-monad ((orig (package->cross-derivation package (mlet %store-monad ((orig (package->cross-derivation package
target system target system
#:graft? #f)) #:graft? #f))
(new (package->cross-derivation replacement (new -> (package->cross-derivation replacement
target system target system
#:graft? #t))) #:graft? #t)))
;; Keep NEW as a monadic value so that its computation
;; is delayed until necessary.
(return (graft (return (graft
(origin orig) (origin orig)
(origin-output output) (origin-output output)

81
tests/packages.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
@ -1091,10 +1091,13 @@
(dummy (dummy-package "dummy" (dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f)) (arguments '(#:implicit-inputs? #f))
(inputs (list dep*))))) (inputs (list dep*)))))
(equal? (package-grafts %store dummy) (match (package-grafts %store dummy)
(list (graft ((graft)
(origin (package-derivation %store dep)) (and (eq? (graft-origin graft)
(replacement (package-derivation %store new))))))) (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 ;; XXX: This test would require building the cross toolchain just to see if it
;; needs grafting, which is obviously too expensive, and thus disabled. ;; needs grafting, which is obviously too expensive, and thus disabled.
@ -1127,10 +1130,13 @@
(dummy (dummy-package "dummy" (dummy (dummy-package "dummy"
(arguments '(#:implicit-inputs? #f)) (arguments '(#:implicit-inputs? #f))
(inputs (list prop))))) (inputs (list prop)))))
(equal? (package-grafts %store dummy) (match (package-grafts %store dummy)
(list (graft ((graft)
(origin (package-derivation %store dep)) (and (eq? (graft-origin graft)
(replacement (package-derivation %store new))))))) (package-derivation %store dep))
(eq? (run-with-store %store
(graft-replacement graft))
(package-derivation %store new)))))))
(test-assert "package-grafts, same replacement twice" (test-assert "package-grafts, same replacement twice"
(let* ((new (dummy-package "dep" (let* ((new (dummy-package "dep"
@ -1149,12 +1155,15 @@
(p3 (dummy-package "final" (p3 (dummy-package "final"
(arguments '(#:implicit-inputs? #f)) (arguments '(#:implicit-inputs? #f))
(inputs (list p1 p2))))) (inputs (list p1 p2)))))
(equal? (package-grafts %store p3) (match (package-grafts %store p3)
(list (graft ((graft)
(origin (package-derivation %store (and (eq? (graft-origin graft)
(package-derivation %store
(package (inherit dep) (package (inherit dep)
(replacement #f)))) (replacement #f))))
(replacement (package-derivation %store new))))))) (eq? (run-with-store %store
(graft-replacement graft))
(package-derivation %store new)))))))
(test-assert "package-grafts, dependency on several outputs" (test-assert "package-grafts, dependency on several outputs"
;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>. ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
@ -1167,17 +1176,22 @@
(p1 (dummy-package "p1" (p1 (dummy-package "p1"
(arguments '(#:implicit-inputs? #f)) (arguments '(#:implicit-inputs? #f))
(inputs (list p0 `(,p0 "lib")))))) (inputs (list p0 `(,p0 "lib"))))))
(lset= equal? (pk (package-grafts %store p1)) (match (sort (package-grafts %store p1)
(list (graft (lambda (graft1 graft2)
(origin (package-derivation %store p0)) (string<? (graft-origin-output graft1)
(origin-output "out") (graft-origin-output graft2))))
(replacement (package-derivation %store p0*)) ((graft1 graft2)
(replacement-output "out")) (and (eq? (graft-origin graft1) (graft-origin graft2)
(graft (package-derivation %store p0))
(origin (package-derivation %store p0)) (eq? (run-with-store %store (graft-replacement graft1))
(origin-output "lib") (run-with-store %store (graft-replacement graft2))
(replacement (package-derivation %store p0*)) (package-derivation %store p0*))
(replacement-output "lib")))))) (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" (test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and ;; We build a DAG as below, where dotted arrows represent replacements and
@ -1244,14 +1258,17 @@
(symlink (assoc-ref %build-inputs "p2") (symlink (assoc-ref %build-inputs "p2")
"p2") "p2")
#t)))))) #t))))))
(lset= equal? (match (package-grafts %store p3)
(package-grafts %store p3) ((graft1 graft2)
(list (graft (and (eq? (graft-origin graft1)
(origin (package-derivation %store p1 #:graft? #f)) (package-derivation %store p1 #:graft? #f))
(replacement (package-derivation %store p1r))) (eq? (run-with-store %store
(graft (graft-replacement graft1))
(origin (package-derivation %store p2 #:graft? #f)) (package-derivation %store p1r))
(replacement (eq? (graft-origin graft2)
(package-derivation %store p2 #:graft? #f))
(eq? (run-with-store %store
(graft-replacement graft2))
(package-derivation %store p2r #:graft? #t))))))) (package-derivation %store p2r #:graft? #t)))))))
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to