GNU bug report logs - #70895
[PATCH] grafts: Only compute necessary graft derivations.

Previous Next

To reply to this bug, email your comments to 70895 AT debbugs.gnu.org.
There is no need to reopen the bug first.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: guix-patches <at> gnu.org
Cc: David Elsing <david.elsing <at> posteo.net>
Subject: [PATCH] grafts: Only compute necessary graft derivations.
Date: Sun, 12 May 2024 13:42:05 +0000

Previously, derivations for grafted packages were computed for all
packages with replacements, regardless of whether they are actually
referenced by the package output in question. This can cause ungrafted
packages to be built even if they are not required.

This commit delays calculating these derivations until they are found to
actually be applicable.

* guix/packages.scm (input-graft): Put <graft-package> records into the
'replacement' field of <graft> records instead of the corresponding
grafted package derivations.
(graft-derivation*): Move to...
(package->derivation, package->cross-derivation) ... here.
* guix/grafts.scm (<graft-package>): New record type.
(cumulative-grafts): Turn the <graft-package> records in the
'replacement' field of applicable grafts into derivations.
---
 guix/grafts.scm   | 41 ++++++++++++++++++++++++++++++++++++-----
 guix/packages.scm | 21 +++++++++++++--------
 2 files changed, 49 insertions(+), 13 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index f4df513daf..5939192864 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -42,18 +42,25 @@ (define-module (guix grafts)
             graft-derivation
             graft-derivation/shallow
 
+            graft-package
+
             %graft-with-utf8-locale?)
   #:re-export (%graft?                            ;for backward compatibility
                without-grafting
                set-grafting
                grafting?))
 
+(define-record-type* <graft-package> graft-package make-graft-package
+  graft-package?
+  (package graft-package-package)
+  (target graft-package-target))
+
 (define-record-type* <graft> graft make-graft
   graft?
   (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 | graft-package
   (replacement-output graft-replacement-output    ;string | #f
                       (default "out")))
 
@@ -283,6 +290,28 @@ (define (dependency-grafts items)
                                       #:system system)))))
           (reference-origins drv items)))
 
+  (define package-derivation
+    (@ (guix packages) package-derivation))
+  (define package-cross-derivation
+    (@ (guix packages) package-cross-derivation))
+
+  ;; Turn all 'replacement' fields which are <graft-package> records into
+  ;; grafted package derivations with #:grafts? #t.
+  (define (calc-remaining-grafts grafts)
+    (map
+     (lambda (item)
+       (graft
+         (inherit item)
+         (replacement
+          (match (graft-replacement item)
+            (($ <graft-package> package target)
+             (if target
+                 (package-cross-derivation
+                  store package target system #:graft? #t)
+                 (package-derivation store package system #:graft? #t)))
+            (new new)))))
+     grafts))
+
   (with-cache (list (derivation-file-name drv) outputs grafts)
     (match (non-self-references store drv outputs)
       (()                                         ;no dependencies
@@ -299,10 +328,12 @@ (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
-                                                        #:outputs outputs
-                                                        #:guile guile
-                                                        #:system system))
+              (let* ((new (graft-derivation/shallow*
+                           store drv
+                           (calc-remaining-grafts applicable)
+                           #:outputs outputs
+                           #:guile guile
+                           #:system system))
                      (grafts (append (map (lambda (output)
                                             (graft
                                               (origin drv)
diff --git a/guix/packages.scm b/guix/packages.scm
index abe89cdb07..1b816d0e24 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1778,8 +1778,9 @@ (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 -> (graft-package
+                                                   (package package)
+                                                   (target #f))))
                         (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 -> (graft-package
+                                          (package package)
+                                          (target target))))
                (return (graft
                          (origin orig)
                          (origin-output output)
@@ -1996,14 +1997,14 @@ (define* (bag->cross-derivation bag #:optional context)
 (define bag->derivation*
   (store-lower bag->derivation))
 
-(define graft-derivation*
-  (store-lift graft-derivation))
-
 (define* (package->derivation package
                               #:optional (system (%current-system))
                               #:key (graft? (%graft?)))
   "Return the <derivation> object of PACKAGE for SYSTEM."
 
+  (define graft-derivation*
+    (store-lift graft-derivation))
+
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; system, will be queried many, many times in a row.
@@ -2030,6 +2031,10 @@ (define* (package->cross-derivation package target
                                     #:key (graft? (%graft?)))
   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 system identifying string)."
+
+  (define graft-derivation*
+    (store-lift graft-derivation))
+
   (mcached (mlet* %store-monad ((bag -> (package->bag package system target
                                                       #:graft? graft?))
                                 (drv (bag->derivation bag package)))
-- 
2.41.0

Message #8 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Mon, 03 Jun 2024 22:58:10 +0200

Hi David,

David Elsing <david.elsing <at> posteo.net> skribis:

> Previously, derivations for grafted packages were computed for all
> packages with replacements, regardless of whether they are actually
> referenced by the package output in question. This can cause ungrafted
> packages to be built even if they are not required.
>
> This commit delays calculating these derivations until they are found to
> actually be applicable.

Neat, good idea!

[...]

>  (define-record-type* <graft> graft make-graft
>    graft?
>    (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 | graft-package
>    (replacement-output graft-replacement-output    ;string | #f
>                        (default "out")))
>  
> @@ -283,6 +290,28 @@ (define (dependency-grafts items)
>                                        #:system system)))))
>            (reference-origins drv items)))
>  
> +  (define package-derivation
> +    (@ (guix packages) package-derivation))
> +  (define package-cross-derivation
> +    (@ (guix packages) package-cross-derivation))
> +
> +  ;; Turn all 'replacement' fields which are <graft-package> records into
> +  ;; grafted package derivations with #:grafts? #t.
> +  (define (calc-remaining-grafts grafts)
> +    (map
> +     (lambda (item)
> +       (graft
> +         (inherit item)
> +         (replacement
> +          (match (graft-replacement item)
> +            (($ <graft-package> package target)
> +             (if target
> +                 (package-cross-derivation
> +                  store package target system #:graft? #t)
> +                 (package-derivation store package system #:graft? #t)))
> +            (new new)))))
> +     grafts))

While this does the job, it breaks an abstraction (grafts are
lower-level than packages) and creates a circular dependency between
(guix grafts) and (guix packages) as a result (not technically a problem
at this point, but it shows that something’s deserves to be clarified).

Maybe there’s a simpler way to achieve this though.  What about allowing
monadic values in the ‘origin’ and ‘replacement’ fields of <graft>?
Their values would be bound lazily, only when needed by
‘graft-derivation’.

WDYT?

Thanks a lot for diving into this!

Ludo’.

Message #11 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Wed, 05 Jun 2024 21:43:16 +0000

Ludovic Courtès <ludo <at> gnu.org> writes:

Hi Ludo',

> While this does the job, it breaks an abstraction (grafts are
> lower-level than packages) and creates a circular dependency between
> (guix grafts) and (guix packages) as a result (not technically a problem
> at this point, but it shows that something’s deserves to be clarified).
>
> Maybe there’s a simpler way to achieve this though.  What about allowing
> monadic values in the ‘origin’ and ‘replacement’ fields of <graft>?
> Their values would be bound lazily, only when needed by
> ‘graft-derivation’.

Yes, that's a good idea, this makes the patch a lot shorter as well.
The 'origin' field need to computed anyway to check whether the graft is
applicable, so only the 'replacement' field needs to be bound lazily.

In cumulative-grafts, I check whether the replacement field is a monadic
value using 'procedure?' and then call 'run-with-store'. Is there a
better way to do this? I see that values in the %state-monad are
repesented as plain lambdas. Also, is it correct to set the
#:guile-for-build and #:system keyword arguments here, as they are
already specified in package->derivation and package->cross-derivation?

As an alternative, is it possible to 'ungexp' a value in the store monad
which returns a derivation? Then the derivation for the 'replacement'
field could be calculated in 'mapping' in 'graft-derivation/shallow'.
I wouldn't know how to define a gexp-compiler though, except by defining
one for any procedure and assuming it is a value in the store monad.

Cheers,
David

Message #14 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: 70895 <at> debbugs.gnu.org
Cc: David Elsing <david.elsing <at> posteo.net>,
 Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH v2] grafts: Only compute necessary graft derivations.
Date: Wed,  5 Jun 2024 21:51:42 +0000

* 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 <at> gnu.org>
+;;; Copyright © 2024 David Elsing <david.elsing <at> 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 <at> telenet.be>
 ;;; Copyright © 2022 jgart <jgart <at> dismail.de>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune <at> gmail.com>
+;;; Copyright © 2024 David Elsing <david.elsing <at> 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

Message #17 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Sun, 19 Jan 2025 00:01:07 +0100

Hi David,

Sorry for not replying earlier.

David Elsing <david.elsing <at> posteo.net> skribis:

>> While this does the job, it breaks an abstraction (grafts are
>> lower-level than packages) and creates a circular dependency between
>> (guix grafts) and (guix packages) as a result (not technically a problem
>> at this point, but it shows that something’s deserves to be clarified).
>>
>> Maybe there’s a simpler way to achieve this though.  What about allowing
>> monadic values in the ‘origin’ and ‘replacement’ fields of <graft>?
>> Their values would be bound lazily, only when needed by
>> ‘graft-derivation’.
>
> Yes, that's a good idea, this makes the patch a lot shorter as well.
> The 'origin' field need to computed anyway to check whether the graft is
> applicable, so only the 'replacement' field needs to be bound lazily.
>
> In cumulative-grafts, I check whether the replacement field is a monadic
> value using 'procedure?' and then call 'run-with-store'. Is there a
> better way to do this? I see that values in the %state-monad are
> repesented as plain lambdas. Also, is it correct to set the
> #:guile-for-build and #:system keyword arguments here, as they are
> already specified in package->derivation and package->cross-derivation?

What you did is correct.  #:guile-for-build and #:system are use to
specify the default value in case it’s not already specified; passing
them here is unnecessary but it cannot hurt.

> As an alternative, is it possible to 'ungexp' a value in the store monad
> which returns a derivation? Then the derivation for the 'replacement'
> field could be calculated in 'mapping' in 'graft-derivation/shallow'.
> I wouldn't know how to define a gexp-compiler though, except by defining
> one for any procedure and assuming it is a value in the store monad.

I’m not sure what you mean since there’s no gexp here.

Ludo’.

Message #22 received at 70895-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895-done <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH v2] grafts: Only compute necessary graft
 derivations.
Date: Sun, 19 Jan 2025 00:02:21 +0100

David Elsing <david.elsing <at> posteo.net> skribis:

> * 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.

It took many months but I finally applied it.  I had to update
graft-related tests in ‘tests/packages.scm’; I also added a couple of
comments in the code.

Thanks for your work, and apologies again for the delay!

Ludo’.

Message #25 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Sun, 19 Jan 2025 21:30:12 +0000

Hi,

Ludovic Courtès <ludo <at> gnu.org> writes:

> What you did is correct.  #:guile-for-build and #:system are use to
> specify the default value in case it’s not already specified; passing
> them here is unnecessary but it cannot hurt.

Ok, thanks!

>> As an alternative, is it possible to 'ungexp' a value in the store monad
>> which returns a derivation? Then the derivation for the 'replacement'
>> field could be calculated in 'mapping' in 'graft-derivation/shallow'.
>> I wouldn't know how to define a gexp-compiler though, except by defining
>> one for any procedure and assuming it is a value in the store monad.
>
> I’m not sure what you mean since there’s no gexp here.

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?

Cheers,
David

Message #28 received at 70895-done <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 70895-done <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH v2] grafts: Only compute necessary graft
 derivations.
Date: Sun, 19 Jan 2025 21:30:00 +0000

Hi Ludo,

Ludovic Courtès <ludo <at> gnu.org> writes:

> It took many months but I finally applied it.  I had to update
> graft-related tests in ‘tests/packages.scm’; I also added a couple of
> comments in the code.

Thank you!

> Thanks for your work, and apologies again for the delay!

No problem, I think it's quite important that the change is working
correctly, because grafts are used all the time.

Best,
David

Message #31 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Tue, 21 Jan 2025 00:27:30 +0100

[Message part 1 (text/plain, inline)]

Hi,

David Elsing <david.elsing <at> posteo.net> 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’.

[Message part 2 (text/x-patch, inline)]

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 <ludo <at> gnu.org>
+;;; Copyright © 2014-2025 Ludovic Courtès <ludo <at> gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement <at> lassieur.org>
 ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke <at> gnu.org>
 ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe <at> gmail.com>
@@ -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

Message #34 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Tue, 21 Jan 2025 21:11:22 +0000

[Message part 1 (text/plain, inline)]

Hi Ludo',

Ludovic Courtès <ludo <at> gnu.org> writes:

> 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.

Oh nice, that's really neat! I didn't know about <parameterized>, that
achieves exactly what I was hoping for.

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

Is there a reason you use 'with-parameters' in 'graft-derivation/shallow'
and not in 'input-graft' and 'input-cross-graft'? I attached a patch
below where I do that and also set %current-system and
%current-target-system (although I'm not sure they are strictly
necessary because of the 'parameterize' in 'bag-grafts').
Then, the changes to the gexp-compiler of <parameterized> are not
required to allow for strings in the 'replacement' field in
tests/grafts.scm and the tests still pass.

Cheers,
David

[grafts.patch (text/x-patch, inline)]

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 7636df9267..e93a5e60bb 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -275,20 +275,6 @@ (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
@@ -305,8 +291,7 @@ (define (finalize-graft item)
               ;; 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..c9e441ffeb 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1817,16 +1817,19 @@ (define (input-graft system)
        (let ((replacement (package-replacement package)))
          (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.
+                      (mlet %store-monad
+                          ((orig (package->derivation package system
+                                                      #:graft? #f))
+                           ;; Do not compute the derivation of REPLACEMENT
+                           ;; yet, as it might not be needed.
+                           (replacement -> (with-parameters
+                                               ((%graft? #t)
+                                                (%current-system system))
+                                             replacement)))
                         (return (graft
                                   (origin orig)
                                   (origin-output output)
-                                  (replacement new)
+                                  (replacement replacement)
                                   (replacement-output output))))
                       package output system)
              (return #f))))
@@ -1840,18 +1843,21 @@ (define (input-cross-graft target system)
       (((? package? package) output)
        (let ((replacement (package-replacement package)))
          (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.
+             (mlet %store-monad
+                 ((orig (package->cross-derivation package
+                                                   target system
+                                                   #:graft? #f))
+                  ;; Do not compuate the derivation of REPLACEMENT
+                  ;; yet, as it might not be needed.
+                  (replacement -> (with-parameters
+                                      ((%graft? #t)
+                                       (%current-system system)
+                                       (%current-target-system target))
+                                    replacement)))
                (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 right-system?
       ((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 right-system?
       ((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 right-system?
                  (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 right-system?
       ((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 right-system?
       ((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

Message #37 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Tue, 28 Jan 2025 16:58:08 +0100

Hello,

David Elsing <david.elsing <at> posteo.net> skribis:

> Is there a reason you use 'with-parameters' in 'graft-derivation/shallow'
> and not in 'input-graft' and 'input-cross-graft'? I attached a patch
> below where I do that and also set %current-system and
> %current-target-system (although I'm not sure they are strictly
> necessary because of the 'parameterize' in 'bag-grafts').
> Then, the changes to the gexp-compiler of <parameterized> are not
> required to allow for strings in the 'replacement' field in
> tests/grafts.scm and the tests still pass.

My thought was that the fact that grafts must be enabled on the
replacement, etc., are implementation details.  I’d like producers of
<graft> records to just be able to drop whatever is relevant to them in
the ‘replacement’ field.

I committed these the patch I sent before as two commits, and I added a
test in ‘tests/gexp.scm’ for ‘with-parameters’:

  28e4018e59 grafts: Allow file-like objects in the ‘replacement’ field of <graft>.
  3ad2d21671 gexp: ‘with-parameters’ accepts plain store items in its body.

Let me know if you notice something wrong.

Thanks a lot for suggesting this, it’s much nicer this way!

Ludo’.

Message #40 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: David Elsing <david.elsing <at> posteo.net>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Wed, 29 Jan 2025 19:30:59 +0000

Hi,

Ludovic Courtès <ludo <at> gnu.org> writes:

> My thought was that the fact that grafts must be enabled on the
> replacement, etc., are implementation details.  I’d like producers of
> <graft> records to just be able to drop whatever is relevant to them in
> the ‘replacement’ field.

Ah sure, that makes sense to me.

> Let me know if you notice something wrong.

I noticed that 'with-parameters' doesn't actually do anything here. :)
The 'graft-origin' is already a derivation anyway, so there it has
obviously no effect. For the 'graft-replacement', I noticed that when
setting %graft? to #f, it still results in the same grafted derivation.
The same was the case in my version using 'with-parameters' in
'input-graft' of course.

I also wanted to use 'with-parameters' for the ROCm packages, but found
that it generally does not work for packages [1], this seems to be also
the case here.
IIUC, this is because 'lower-object' returns a monadic procedure, which
is evaluated outside the influence of 'with-fluids' in the gexp-compiler
of <parameterized>.

The grafting still works correctly however, I think because the %graft?
parameter is also set when the derivations are actually calculated,
while in 'input-graft', 'package->derivation' is explicitely called with
#:graft? set to #f.

What do you think?

Best,
David

[1] https://issues.guix.gnu.org/75879

Message #43 received at 70895 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: David Elsing <david.elsing <at> posteo.net>
Cc: 70895 <at> debbugs.gnu.org
Subject: Re: [bug#70895] [PATCH] grafts: Only compute necessary graft
 derivations.
Date: Fri, 31 Jan 2025 17:26:13 +0100

Hi David,

David Elsing <david.elsing <at> posteo.net> skribis:

>> My thought was that the fact that grafts must be enabled on the
>> replacement, etc., are implementation details.  I’d like producers of
>> <graft> records to just be able to drop whatever is relevant to them in
>> the ‘replacement’ field.
>
> Ah sure, that makes sense to me.
>
>> Let me know if you notice something wrong.
>
> I noticed that 'with-parameters' doesn't actually do anything here. :)
> The 'graft-origin' is already a derivation anyway, so there it has
> obviously no effect. For the 'graft-replacement', I noticed that when
> setting %graft? to #f, it still results in the same grafted derivation.
> The same was the case in my version using 'with-parameters' in
> 'input-graft' of course.

Hmm.  For ‘graft-origin’, it doesn’t really matter; but the replacement,
it does.

> The grafting still works correctly however, I think because the %graft?
> parameter is also set when the derivations are actually calculated,
> while in 'input-graft', 'package->derivation' is explicitely called with
> #:graft? set to #f.

OK, pfew.

> [1] https://issues.guix.gnu.org/75879

Uh, looks like this is a real bug.  I’m surprised because we do have
tests for that in ‘tests/gexp.scm’ (and it’s actually used in a few
important places), but maybe they’re not exercising the right thing.

Ludo’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.