[bug#70895] [PATCH v2] grafts: Only compute necessary graft derivations.

[David Elsing]

* 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.
---
 guix/grafts.scm   | 18 +++++++++++++++++-
 guix/packages.scm | 11 ++++++-----
 2 files changed, 23 insertions(+), 6 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index f4df513daf..2f2ddbc83a 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -283,6 +284,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
@@ -299,7 +314,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))
diff --git a/guix/packages.scm b/guix/packages.scm
index abe89cdb07..946ccc693a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2022 jgart <jgart@dismail.de>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2024 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1778,8 +1779,8 @@ (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)))
                         (return (graft
                                   (origin orig)
                                   (origin-output output)
@@ -1800,9 +1801,9 @@ (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)))
                (return (graft
                          (origin orig)
                          (origin-output output)
-- 
2.41.0