[PATCH] grafts: Only compute necessary graft derivations.

  • Open
  • quality assurance status badge
Details
2 participants
  • David Elsing
  • Ludovic Courtès
Owner
unassigned
Submitted by
David Elsing
Severity
normal
D
D
David Elsing wrote on 12 May 15:42 +0200
(address . guix-patches@gnu.org)(name . David Elsing)(address . david.elsing@posteo.net)
20240512134301.2234-1-david.elsing@posteo.net
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(-)

Toggle diff (137 lines)
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
L
L
Ludovic Courtès wrote on 3 Jun 22:58 +0200
(name . David Elsing)(address . david.elsing@posteo.net)(address . 70895@debbugs.gnu.org)
87zfs1921p.fsf@gnu.org
Hi David,

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

Toggle quote (8 lines)
> 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!

[...]

Toggle quote (36 lines)
> (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’.
D
D
David Elsing wrote on 5 Jun 23:43 +0200
(name . Ludovic Courtès)(address . ludo@gnu.org)(address . 70895@debbugs.gnu.org)
7ycyov5amj.fsf@posteo.net
Ludovic Courtès <ludo@gnu.org> writes:

Hi Ludo',

Toggle quote (10 lines)
> 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
D
D
David Elsing wrote on 5 Jun 23:51 +0200
[PATCH v2] grafts: Only compute necessary graft derivations.
(address . 70895@debbugs.gnu.org)
86be6fa895a3a5d9625a49e11181f483fca3c462.1717623537.git.david.elsing@posteo.net
* 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(-)

Toggle diff (80 lines)
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
?
Your comment

Commenting via the web interface is currently disabled.

To comment on this conversation send an email to 70895@debbugs.gnu.org

To respond to this issue using the mumi CLI, first switch to it
mumi current 70895
Then, you may apply the latest patchset in this issue (with sign off)
mumi am -- -s
Or, compose a reply to this issue
mumi compose
Or, send patches to this issue
mumi send-email *.patch