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

From: Ludovic Courtès <[email-masked]>
Date: Tue, 21 Jan 2025 00:27:30 +0100

Hi,

David Elsing <[email-masked]> skribis:

> I meant that in 'graft-derivation/shallow', the 'mapping' variable is a
> list of gexps, where 'ungexp' is called on the graft-replacement of the
> grafts. So instead of turning the monadic value into a derivation
> beforehand, this could be done here instead, right? Considering a
> gexp-compiler returns a store monad value of a derivation (IIUC), my
> question was whether it is possible to use such a value in a gexp
> directly (i.e. without the 'return' in the gexp-compiler for a
> derivation, such that the evaluation of the derivation is delayed until
> the gexp is lowered to a derivation). These values would still need to
> be identified by 'procedure?' I guess, so it would not be better than
> currently.
> Does this make sense or did I misunderstand something?

Oh, got it.  Yes, we could keep a <package> in the ‘replacement’ field
instead of explicitly calling ‘package->derivation’.  It’s much simpler,
that’s a good idea.

I gave it a try, see patch attached.  Let me know what you think!

Ludo’.

diff --git a/guix/gexp.scm b/guix/gexp.scm
index e44aea6420..d6a429e60e 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2024 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2014-2025 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2018 Clément Lassieur <[email-masked]>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <[email-masked]>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <[email-masked]>
@@ -747,7 +747,12 @@ (define-gexp-compiler compile-parameterized <parameterized>
                    (target (if (memq %current-target-system parameters)
                                (%current-target-system)
                                target)))
-               (lower-object (thunk) system #:target target))))))))
+               (match (thunk)
+                 ((? struct? obj)
+                  (lower-object obj system #:target target))
+                 (obj
+                  (with-monad %store-monad
+                    (return obj)))))))))))
 
   expander => (lambda (parameterized lowered output)
                 (match (parameterized-bindings parameterized)
@@ -758,10 +763,13 @@ (define-gexp-compiler compile-parameterized <parameterized>
                      (with-fluids* fluids
                        (map (lambda (thunk) (thunk)) values)
                        (lambda ()
-                         ;; Delegate to the expander of the wrapped object.
-                         (let* ((base   (thunk))
-                                (expand (lookup-expander base)))
-                           (expand base lowered output)))))))))
+                         (match (thunk)
+                           ((? struct? base)
+                            ;; Delegate to the expander of the wrapped object.
+                            (let ((expand (lookup-expander base)))
+                              (expand base lowered output)))
+                           (obj
+                            obj)))))))))
 
 
 ;;;
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 7636df9267..98ef1e4058 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -101,9 +101,11 @@ (define* (graft-derivation/shallow drv grafts
     ;; List of store item pairs.
     (map (lambda (graft)
            (gexp
-            ((ungexp (graft-origin graft)
+            ((ungexp (with-parameters ((%graft? #f))
+                       (graft-origin graft))
                      (graft-origin-output graft))
-             . (ungexp (graft-replacement graft)
+             . (ungexp (with-parameters ((%graft? #t))
+                         (graft-replacement graft))
                        (graft-replacement-output graft)))))
          grafts))
 
@@ -275,20 +277,6 @@ (define* (cumulative-grafts store drv 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
@@ -305,8 +293,7 @@ (define* (cumulative-grafts store drv 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
-                                                        (map finalize-graft applicable)
+              (let* ((new    (graft-derivation/shallow* store drv applicable
                                                         #:outputs outputs
                                                         #:guile guile
                                                         #:system system))
diff --git a/guix/packages.scm b/guix/packages.scm
index d266805ba8..78726b089a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1818,15 +1818,13 @@ (define (input-graft system)
          (if replacement
              (mcached eq? (=> %package-graft-cache)
                       (mlet %store-monad ((orig (package->derivation package system
-                                                                     #:graft? #f))
-                                          (new -> (package->derivation replacement system
-                                                                       #:graft? #t)))
-                        ;; Keep NEW as a monadic value so that its computation
-                        ;; is delayed until necessary.
+                                                                     #:graft? #f)))
+                        ;; Keep REPLACEMENT as a package so that its
+                        ;; derivation is computed only when necessary.
                         (return (graft
                                   (origin orig)
                                   (origin-output output)
-                                  (replacement new)
+                                  (replacement replacement)
                                   (replacement-output output))))
                       package output system)
              (return #f))))
@@ -1842,16 +1840,13 @@ (define (input-cross-graft target system)
          (if replacement
              (mlet %store-monad ((orig (package->cross-derivation package
                                                                   target system
-                                                                  #:graft? #f))
-                                 (new -> (package->cross-derivation replacement
-                                                                    target system
-                                                                    #:graft? #t)))
-               ;; Keep NEW as a monadic value so that its computation
-               ;; is delayed until necessary.
+                                                                  #:graft? #f)))
+               ;; Keep REPLACEMENT as a package so that its derivation is
+               ;; computed only when necessary.
                (return (graft
                          (origin orig)
                          (origin-output output)
-                         (replacement new)
+                         (replacement replacement)
                          (replacement-output output))))
              (return #f))))
       (_
diff --git a/tests/packages.scm b/tests/packages.scm
index a4a0e2c3e8..2863fb5991 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1095,9 +1095,7 @@ (define compressors '(("gzip"  . "gz")
       ((graft)
        (and (eq? (graft-origin graft)
                  (package-derivation %store dep))
-            (eq? (run-with-store %store
-                   (graft-replacement graft))
-                 (package-derivation %store new)))))))
+            (eq? (graft-replacement graft) 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.
@@ -1134,9 +1132,7 @@ (define compressors '(("gzip"  . "gz")
       ((graft)
        (and (eq? (graft-origin graft)
                  (package-derivation %store dep))
-            (eq? (run-with-store %store
-                   (graft-replacement graft))
-                 (package-derivation %store new)))))))
+            (eq? (graft-replacement graft) new))))))
 
 (test-assert "package-grafts, same replacement twice"
   (let* ((new  (dummy-package "dep"
@@ -1161,9 +1157,7 @@ (define compressors '(("gzip"  . "gz")
                  (package-derivation %store
                                      (package (inherit dep)
                                               (replacement #f))))
-            (eq? (run-with-store %store
-                   (graft-replacement graft))
-                 (package-derivation %store new)))))))
+            (eq? (graft-replacement graft) new))))))
 
 (test-assert "package-grafts, dependency on several outputs"
   ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
@@ -1183,9 +1177,9 @@ (define compressors '(("gzip"  . "gz")
       ((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*))
+            (eq? (graft-replacement graft1)
+                 (graft-replacement graft2)
+                 p0*)
             (string=? "lib"
                       (graft-origin-output graft1)
                       (graft-replacement-output graft1))
@@ -1262,14 +1256,10 @@ (define compressors '(("gzip"  . "gz")
       ((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-replacement graft1) 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)))))))
+            (eq? (graft-replacement graft2) p2r))))))
 
 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
 ;;; find out about their run-time dependencies, so this test is no longer