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

From: [email-masked] (GNU bug Tracking System)
Date: Sat, 18 Jan 2025 23:03:02 +0000

Your bug report

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

which was filed against the guix-patches package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
70895: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=70895
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: [bug#70895] [PATCH v2] grafts: Only compute necessary graft derivations.
From: Ludovic Courtès <[email-masked]>
To: David Elsing <[email-masked]>
Cc: [email-masked]
Date: Sun, 19 Jan 2025 00:02:21 +0100
List-Id: <debbugs-submit.debbugs.gnu.org>

David Elsing <[email-masked]> 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’.

Subject: [PATCH] grafts: Only compute necessary graft derivations.
From: David Elsing <[email-masked]>
To: [email-masked]
Cc: David Elsing <[email-masked]>
Date: Sun, 12 May 2024 13:42:05 +0000
List-Id: <debbugs-submit.debbugs.gnu.org>

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