diff options
author | Ludovic Courtès <ludo@gnu.org> | 2022-10-14 23:01:33 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-10-22 01:49:57 +0200 |
commit | 863c228bfd53aac478eee46f6ee54d87fee9d764 (patch) | |
tree | 77f61d4448dbd3f29123ebc80d023cd52cd812bf /guix/grafts.scm | |
parent | a3619079f95213c4f983e69210ed12b38fd31022 (diff) | |
download | guix-patches-863c228bfd53aac478eee46f6ee54d87fee9d764.tar guix-patches-863c228bfd53aac478eee46f6ee54d87fee9d764.tar.gz |
grafts: Rewrite using gexps.
Fixes <https://issues.guix.gnu.org/58419>.
* guix/grafts.scm (graft-derivation/shallow): Rewrite using gexps and
remove 'store' parameter.
(graft-derivation/shallow*): New variable.
(cumulative-grafts): Use it instead of 'graft-derivation/shallow'.
Diffstat (limited to 'guix/grafts.scm')
-rw-r--r-- | guix/grafts.scm | 113 |
1 files changed, 51 insertions, 62 deletions
diff --git a/guix/grafts.scm b/guix/grafts.scm index 252abfd8b3..1686aa1413 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (guix sets) + #:use-module (guix gexp) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -78,7 +79,7 @@ (($ <graft> (? string? item)) item))) -(define* (graft-derivation/shallow store drv grafts +(define* (graft-derivation/shallow drv grafts #:key (name (derivation-name drv)) (outputs (derivation-output-names drv)) @@ -87,72 +88,60 @@ "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." - ;; XXX: Someday rewrite using gexps. (define mapping ;; List of store item pairs. - (map (match-lambda - (($ <graft> source source-output target target-output) - (cons (if (derivation? source) - (derivation->output-path source source-output) - source) - (if (derivation? target) - (derivation->output-path target target-output) - target)))) + (map (lambda (graft) + (gexp + ((ungexp (graft-origin graft) + (graft-origin-output graft)) + . (ungexp (graft-replacement graft) + (graft-replacement-output graft))))) grafts)) - (define output-pairs - (map (lambda (output) - (cons output - (derivation-output-path - (assoc-ref (derivation-outputs drv) output)))) - outputs)) - (define build - `(begin - (use-modules (guix build graft) - (guix build utils) - (ice-9 match)) - - (let* ((old-outputs ',output-pairs) - (mapping (append ',mapping - (map (match-lambda - ((name . file) - (cons (assoc-ref old-outputs name) - file))) - %outputs)))) - (graft old-outputs %outputs mapping)))) - - (define add-label - (cut cons "x" <>)) + (with-imported-modules '((guix build graft) + (guix build utils) + (guix build debug-link) + (guix elf)) + #~(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (define %outputs + (ungexp (outputs->gexp outputs))) + + (let* ((old-outputs '(ungexp + (map (lambda (output) + (gexp ((ungexp output) + . (ungexp drv output)))) + outputs))) + (mapping (append '(ungexp mapping) + (map (match-lambda + ((name . file) + (cons (assoc-ref old-outputs name) + file))) + %outputs)))) + (graft old-outputs %outputs mapping))))) + (define properties `((type . graft) (graft (count . ,(length grafts))))) - (match grafts - ((($ <graft> sources source-outputs targets target-outputs) ...) - (let ((sources (zip sources source-outputs)) - (targets (zip targets target-outputs))) - (build-expression->derivation store name build - #:system system - #:guile-for-build guile - #:modules '((guix build graft) - (guix build utils) - (guix build debug-link) - (guix elf)) - #:inputs `(,@(map (lambda (out) - `("x" ,drv ,out)) - outputs) - ,@(append (map add-label sources) - (map add-label targets))) - #:outputs outputs - - ;; Grafts are computationally cheap so no - ;; need to offload or substitute. - #:local-build? #t - #:substitutable? #f - - #:properties properties))))) + (gexp->derivation name build + #:system system + #:guile-for-build guile + + ;; Grafts are computationally cheap so no + ;; need to offload or substitute. + #:local-build? #t + #:substitutable? #f + + #:properties properties)) + +(define graft-derivation/shallow* + (store-lower graft-derivation/shallow)) (define (non-self-references store drv outputs) "Return the list of references of the OUTPUTS of DRV, excluding self @@ -291,10 +280,10 @@ derivations to the corresponding set of 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 applicable - #:outputs outputs - #:guile guile - #:system system)) + (let* ((new (graft-derivation/shallow* store drv applicable + #:outputs outputs + #:guile guile + #:system system)) (grafts (append (map (lambda (output) (graft (origin drv) |