(address . guix-patches@gnu.org)(name . David Elsing)(address . david.elsing@posteo.net)
20231029184113.13199-1-david.elsing@posteo.net
For a grafted package, a symbolic link is created to the ungrafted package in
the .guix-grafts subdirectory. This is activated by default can be disabled by
passing the --no-graft-reference-original option.
---
This addresses https://issues.guix.gnu.org/54495.Would something like
this be acceptable? In my opinion, it would make garbage collector
roots much more useful in the presence of grafts.
I named the symlink file by the store directory name of the grafted
package itself to avoid collisions.
Most of this patch consists of passing graft-reference-original? around
in addition to graft?, I'm not sure of the name however.
When graft? is #f, the derivations are the same regardless of
graft-reference-original?, so it does not need to be set to #f in the
--no-grafts case.
guix/build/graft.scm | 22 +++++++++++++++++-----
guix/gexp.scm | 26 ++++++++++++++++++++++----
guix/grafts.scm | 24 +++++++++++++++++-------
guix/packages.scm | 13 ++++++++++---
guix/scripts.scm | 8 ++++++--
guix/scripts/archive.scm | 5 ++++-
guix/scripts/build.scm | 22 ++++++++++++++++++++--
guix/scripts/environment.scm | 5 ++++-
guix/scripts/home.scm | 5 ++++-
guix/scripts/package.scm | 5 ++++-
guix/scripts/pull.scm | 5 ++++-
guix/scripts/shell.scm | 12 +++++++++---
guix/scripts/system.scm | 5 ++++-
guix/store.scm | 18 ++++++++++++++++++
14 files changed, 143 insertions(+), 32 deletions(-)
Toggle diff (372 lines)
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 281dbaba6f..83a7f20f76 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -340,7 +340,8 @@ (define not-slash
(() #t))))
(define* (rewrite-directory directory output mapping
- #:optional (store (%store-directory)))
+ #:optional (store (%store-directory))
+ #:key (reference-original? #t))
"Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
file name pairs."
@@ -417,7 +418,14 @@ (define (rewrite-leaf file)
(exit-on-exception rewrite-leaf)
(find-files directory (const #t)
#:directories? #t))
- (rename-matching-files output mapping))
+ (rename-matching-files output mapping)
+
+ (when reference-original?
+ ;; Create a symbolic link to the original directory
+ (mkdir-p* (string-append output "/.guix-grafts"))
+ (symlink directory
+ (string-append output "/.guix-grafts/"
+ (basename output)))))
(define %graft-hooks
;; Default list of hooks run after grafting.
@@ -425,14 +433,18 @@ (define %graft-hooks
(define* (graft old-outputs new-outputs mapping
#:key (log-port (current-output-port))
- (hooks %graft-hooks))
+ (hooks %graft-hooks)
+ (reference-original? #t))
"Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to
NEW-OUTPUTS. MAPPING must be a list of file name pairs; OLD-OUTPUTS and
-NEW-OUTPUTS are lists of output name/file name pairs."
+NEW-OUTPUTS are lists of output name/file name pairs. If REFERENCE-ORIGINAL?
+is #t, a symlink to the corresponding directory in NEW-OUTPUTS is added to
+each directory in OLD-OUTPUTS."
(for-each (lambda (input output)
(format log-port "grafting '~a' -> '~a'...~%" input output)
(force-output)
- (rewrite-directory input output mapping))
+ (rewrite-directory input output mapping
+ #:reference-original? reference-original?))
(match old-outputs
(((names . files) ...)
files))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 0fe4f1c98a..6cf4da0cdc 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -286,7 +286,8 @@ (define* (lower-object obj
(mlet %store-monad ((target (if (eq? target 'current)
(current-target-system)
(return target)))
- (graft? (grafting?)))
+ (graft? (grafting?))
+ (graft-reference-original? (graft-referencing-original?)))
(let loop ((obj obj))
(match (lookup-compiler obj)
(#f
@@ -302,7 +303,8 @@ (define* (lower-object obj
(loop lowered)
(return lowered)))
obj
- system target graft?)))))))
+ system target graft?
+ graft-reference-original?)))))))
(define* (lower+expand-object obj
#:optional (system (%current-system))
@@ -317,11 +319,14 @@ (define* (lower+expand-object obj
(raise (condition (&gexp-input-error (input obj)))))
(lower
(mlet* %store-monad ((graft? (grafting?))
+ (graft-reference-original?
+ (graft-referencing-original?))
(lowered (if (derivation? obj)
(return obj)
(mcached (lower obj system target)
- obj
- system target graft?))))
+ obj system target
+ graft?
+ graft-reference-original?))))
;; LOWER might return something that needs to be further
;; lowered.
(if (struct? lowered)
@@ -1011,6 +1016,7 @@ (define* (lower-gexp exp
(system (%current-system))
(target 'current)
(graft? (%graft?))
+ (graft-reference-original? (%graft-reference-original?))
(guile-for-build (%guile-for-build))
(effective-version "3.0")
@@ -1047,6 +1053,8 @@ (define (search-path modules extensions suffix)
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
+ (graft-reference-original?
+ (set-graft-reference-original graft-reference-original?))
(system -> (or system (%current-system)))
(target -> (if (eq? target 'current)
@@ -1073,6 +1081,7 @@ (define (search-path modules extensions suffix)
#:module-path module-path))
(modules -> (car modules+compiled))
(compiled -> (cdr modules+compiled)))
+
(define load-path
(search-path modules exts
(string-append "/share/guile/site/" effective-version)))
@@ -1084,6 +1093,7 @@ (define load-compiled-path
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
+ (set-graft-reference-original graft-reference-original?)
(return (lowered-gexp sexp
`(,@(if (derivation? modules)
(list (derivation-input modules))
@@ -1108,6 +1118,8 @@ (define* (gexp->derivation name exp
(guile-for-build (%guile-for-build))
(effective-version "3.0")
(graft? (%graft?))
+ (graft-reference-original?
+ (%graft-reference-original?))
references-graphs
allowed-references disallowed-references
leaked-env-vars
@@ -1158,6 +1170,7 @@ (define* (gexp->derivation name exp
The other arguments are as for 'derivation'."
(define outputs (gexp-outputs exp))
(define requested-graft? graft?)
+ (define requested-graft-reference-original? graft-reference-original?)
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@@ -1181,6 +1194,8 @@ (define (add-modules exp modules)
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
+ (graft-reference-original?
+ (set-graft-reference-original graft-reference-original?))
(system -> (or system (%current-system)))
(target -> (if (eq? target 'current)
@@ -1192,6 +1207,8 @@ (define (add-modules exp modules)
#:system system
#:target target
#:graft? requested-graft?
+ #:graft-reference-original?
+ requested-graft-reference-original?
#:guile-for-build
guile-for-build
#:effective-version
@@ -1220,6 +1237,7 @@ (define (add-modules exp modules)
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
+ (set-graft-reference-original graft-reference-original?)
(raw-derivation name
(string-append (derivation-input-output-path guile)
"/bin/guile")
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 48f4c212f7..c232fd509d 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -44,6 +44,7 @@ (define-module (guix grafts)
%graft-with-utf8-locale?)
#:re-export (%graft? ;for backward compatibility
+ %graft-reference-original?
without-grafting
set-grafting
grafting?))
@@ -92,7 +93,8 @@ (define* (graft-derivation/shallow drv grafts
(name (derivation-name drv))
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Return a derivation called NAME, which applies GRAFTS to the specified
OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS
are not recursively applied to dependencies of DRV."
@@ -144,7 +146,8 @@ (define %outputs
(cons (assoc-ref old-outputs name)
file)))
%outputs))))
- (graft old-outputs %outputs mapping)))))
+ (graft old-outputs %outputs mapping
+ #:reference-original? #$reference-original?)))))
(define properties
@@ -246,7 +249,8 @@ (define* (cumulative-grafts store drv grafts
#:key
(outputs (derivation-output-names drv))
(guile (%guile-for-build))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Augment GRAFTS with additional grafts resulting from the application of
GRAFTS to the dependencies of DRV. Return the resulting list of grafts.
@@ -278,7 +282,9 @@ (define (dependency-grafts items)
(cumulative-grafts store drv grafts
#:outputs (list output)
#:guile guile
- #:system system)))))
+ #:system system
+ #:reference-original?
+ reference-original?)))))
(reference-origins drv items)))
(with-cache (list (derivation-file-name drv) outputs grafts)
@@ -300,7 +306,9 @@ (define (dependency-grafts items)
(let* ((new (graft-derivation/shallow* store drv applicable
#:outputs outputs
#:guile guile
- #:system system))
+ #:system system
+ #:reference-original?
+ reference-original?))
(grafts (append (map (lambda (output)
(graft
(origin drv)
@@ -315,7 +323,8 @@ (define* (graft-derivation store drv grafts
#:key
(guile (%guile-for-build))
(outputs (derivation-output-names drv))
- (system (%current-system)))
+ (system (%current-system))
+ (reference-original? #t))
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
DRV, and graft DRV itself to refer to those grafted dependencies."
@@ -323,7 +332,8 @@ (define* (graft-derivation store drv grafts
(run-with-state
(cumulative-grafts store drv grafts
#:outputs outputs
- #:guile guile #:system system)
+ #:guile guile #:system system
+ #:reference-original? reference-original?)
(store-connection-cache store %graft-cache))))
;; Save CACHE in STORE to benefit from it on the next call.
diff --git a/guix/packages.scm b/guix/packages.scm
index e2e82692ad..41dec95355 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1962,7 +1962,10 @@ (define graft-derivation*
(define* (package->derivation package
#:optional (system (%current-system))
- #:key (graft? (%graft?)))
+ #:key
+ (graft? (%graft?))
+ (graft-reference-original?
+ (%graft-reference-original?)))
"Return the <derivation> object of PACKAGE for SYSTEM."
;; Compute the derivation and cache the result. Caching is important
@@ -1982,7 +1985,9 @@ (define* (package->derivation package
system #:graft? #f)))
(graft-derivation* drv grafts
#:system system
- #:guile guile)))))
+ #:guile guile
+ #:reference-original?
+ graft-reference-original?)))))
(return drv)))
package system #f graft?))
@@ -2005,7 +2010,9 @@ (define* (package->cross-derivation package target
system #:graft? #f)))
(graft-derivation* drv grafts
#:system system
- #:guile guile)))))
+ #:guile guile
+ #:reference-original?
+ graft-reference-original?)))))
(return drv)))
package system target graft?))
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 5d11ce7fe9..7f9e53b28f 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -197,13 +197,17 @@ (define* (build-package package
#:rest build-options)
"Build PACKAGE using BUILD-OPTIONS acceptable by 'set-build-options'.
Show what and how will/would be built."
- (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad))))
+ (mlet %store-monad ((grafting? ((lift0 %graft? %store-monad)))
+ (graft-reference-original?
+ ((lift0 %graft-reference-original? %store-monad))))
(apply set-build-options*
#:use-substitutes? use-substitutes?
(strip-keyword-arguments '(#:dry-run?) build-options))
(mlet %store-monad ((derivation (package->derivation
package #:graft? (and (not dry-run?)
- grafting?))))
+ grafting?)
+ #:graft-reference-original?
+ graft-reference-original?)))
(mbegin %store-monad
(maybe-build (list derivation)
#:use-substitutes? use-substitutes?
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 2b5a55a23f..34151d70b6 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -58,6 +58,7 @@ (define %default-options
(substitutes? . #t)
(offload? . #t)
(graft? . #t)
+ (graft-reference-original? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
@@ -377,7 +378,9 @@ (define (lines port)
(with-error-handling
(let ((opts (parse-command-line args %options (list %default-options))))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%graft-reference-original?
+ (assoc-ref opts 'graft-reference-original?)))
(cond ((assoc-ref opts 'generate-key)
=>
generate-key-pair)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 05f022a92e..c17d84bd20 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -170,6 +170,10 @@ (define (show-build-options-help)
fetch substitute from URLS if they are authorized"))
(display (G_ "
--no-grafts do not graft packages"))
+ (display (G_ "
+ --no-graft-reference-original
+ for grafted packages, do not reference the ungrafted
+ version"))
(display (G_ "
--no-offload do not attempt to offload builds"))
(display (G_ "
@@ -290,6 +294,13 @@ (define %standard-build-options
(alist-cons 'graft? #f
(alist-delete 'graft? result eq?))
rest)))
+ (option '("no-graft-reference-original") #f #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons
+ 'graft-reference-original? #f
+ (alist-delete 'graft-reference-original? result))
+ rest)))
(option '("no-offload" "no-build-hook") #f #f
(lambda (opt name arg result . rest)
(when (string=? name "no-build-hook")
@@ -418,6 +429,7 @@ (define %default-options
;; Alist of default option values.
`((build-mode . ,(build-mode normal))
(graft? . #t)
+ (graft-reference
This message was truncated. Download the full message here.