Package: guix-patches;
Reported by: David Elsing <david.elsing <at> posteo.net>
Date: Sun, 12 May 2024 13:44:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Ludovic Courtès <ludo <at> gnu.org> To: David Elsing <david.elsing <at> posteo.net> Cc: 70895 <at> debbugs.gnu.org Subject: [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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.