From 3331d675fbf5287e8cbe12af48fb2de14f1ad8bc Mon Sep 17 00:00:00 2001 From: David Elsing Date: Wed, 5 Jun 2024 21:51:42 +0000 Subject: [PATCH] grafts: Only compute necessary graft derivations. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/packages.scm (input-graft, input-cross-graft): Store the monadic value of the replacement in the 'replacement' field of 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 records directly, compare the relevant fields instead, calling ‘run-with-store’ on the ‘replacement’ field. Co-authored-by: Ludovic Courtès Change-Id: Idded0a402b8974df1ef2354f1a88c308b9b99777 --- guix/grafts.scm | 20 +++++++++-- guix/packages.scm | 15 +++++--- tests/packages.scm | 87 +++++++++++++++++++++++++++------------------- 3 files changed, 80 insertions(+), 42 deletions(-) diff --git a/guix/grafts.scm b/guix/grafts.scm index d97e112ba4..7636df9267 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014-2024 Ludovic Courtès +;;; Copyright © 2024 David Elsing ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,7 +54,7 @@ (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 @@ derivations to the corresponding set of grafts." #:system system))))) (reference-origins drv items))) + ;; If the 'replacement' field of the 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 @@ derivations to the corresponding set of grafts." ;; 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)) diff --git a/guix/packages.scm b/guix/packages.scm index ff9fbd8470..d266805ba8 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -11,6 +11,7 @@ ;;; Copyright © 2022 jgart ;;; Copyright © 2023 Simon Tournier ;;; Copyright © 2024 Janneke Nieuwenhuizen +;;; Copyright © 2024 David Elsing ;;; ;;; This file is part of GNU Guix. ;;; @@ -1818,8 +1819,10 @@ graft, and #f otherwise." (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 @@ graft, and #f otherwise." (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) diff --git a/tests/packages.scm b/tests/packages.scm index 9713262d4c..a4a0e2c3e8 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2024 Ludovic Courtès +;;; Copyright © 2012-2025 Ludovic Courtès ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Maxime Devos @@ -1091,10 +1091,13 @@ (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 @@ (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 @@ (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 . @@ -1167,17 +1176,22 @@ (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