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

Previous Next

Full log

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

Previous Next

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