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 <[email protected]>
Change-Id: Idded0a402b8974df1ef2354f1a88c308b9b99777

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 <[email protected]>
+;;; Copyright © 2024 David Elsing <[email protected]>
 ;;;
 ;;; 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 <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 @@ 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 <[email protected]>
 ;;; Copyright © 2023 Simon Tournier <[email protected]>
 ;;; Copyright © 2024 Janneke Nieuwenhuizen <[email protected]>
+;;; Copyright © 2024 David Elsing <[email protected]>
 ;;;
 ;;; 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 <[email protected]>
+;;; Copyright © 2012-2025 Ludovic Courtès <[email protected]>
 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <[email protected]>
 ;;; Copyright © 2021 Maxim Cournoyer <[email protected]>
 ;;; Copyright © 2021 Maxime Devos <[email protected]>
@@ -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 <https://bugs.gnu.org/41796>.
@@ -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<? (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 @@
                                (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