From 4ff12d1de7cd617b791996ee7ca1240660b4c20e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 May 2022 17:17:10 +0200 Subject: profiles: Do not repeat entries in 'manifest' file. Fixes . Reported by Ricardo Wurmus . With this change, the manifest file created for: guix install r r-seurat r-cistopic r-monocle3 r-cicero-monocle3 r-assertthat goes from 5.7M to 176K. Likewise, on this profile, wall-clock time of: GUIX_PROFILING=gc guix package -I goes from 0.7s to 0.1s, with heap usage going from 55M to 9M. * guix/profiles.scm (manifest->gexp)[optional]: New procedure. [entry->gexp]: Turn into a monadic procedure. Return a 'repeated' sexp if ENTRY was already visited before. Adjust caller accordingly. Bump manifest version. (sexp->manifest)[sexp->manifest-entry]: Turn into a monadic procedure. Add case for 'repeated' nodes. Add each entry to the current state vhash. Add clause for version 4 manifests. [sexp->manifest-entry/v3]: New procedure, with former 'sexp->manifest-entry' code. * tests/profiles.scm ("deduplication of repeated entries"): New test. * guix/build/profiles.scm (manifest-sexp->inputs+search-paths)[let-fields]: New macro. Use it. Expect version 4. Add clause for 'repeated' nodes. --- guix/build/profiles.scm | 32 +++++++++++++++++++++++++------- 1 file changed, 25 insertions(+), 7 deletions(-) (limited to 'guix/build') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index f9875ca92e..2ab76bde74 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -149,19 +149,33 @@ instead make DIRECTORY a \"real\" directory containing symlinks." "Parse MANIFEST, an sexp as produced by 'manifest->gexp', and return two values: the list of store items of its manifest entries, and the list of search path specifications." + (define-syntax let-fields + (syntax-rules () + ;; Bind the fields NAME of LST to same-named variables in the lexical + ;; scope of BODY. + ((_ lst (name rest ...) body ...) + (let ((name (match (assq 'name lst) + ((_ value) value) + (#f '())))) + (let-fields lst (rest ...) body ...))) + ((_ lst () body ...) + (begin body ...)))) + (match manifest ;this must match 'manifest->gexp' - (('manifest ('version 3) + (('manifest ('version 4) ('packages (entries ...))) (let loop ((entries entries) (inputs '()) (search-paths '())) (match entries - (((name version output item - ('propagated-inputs deps) - ('search-paths paths) _ ...) . rest) - (loop (append rest deps) ;breadth-first traversal - (cons item inputs) - (append paths search-paths))) + (((name version output item fields ...) . rest) + (let ((paths search-paths)) + (let-fields fields (propagated-inputs search-paths properties) + (loop (append rest propagated-inputs) ;breadth-first traversal + (cons item inputs) + (append search-paths paths))))) + ((('repeated name version item) . rest) + (loop rest inputs search-paths)) (() (values (reverse inputs) (delete-duplicates @@ -212,4 +226,8 @@ search paths of MANIFEST's entries." ;; Write 'OUTPUT/etc/profile'. (build-etc/profile output search-paths))) +;;; Local Variables: +;;; eval: (put 'let-fields 'scheme-indent-function 2) +;;; End: + ;;; profile.scm ends here -- cgit v1.2.3 From 89e22887510ba5d546a4d7e391462e648942a7b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jul 2022 12:26:50 +0200 Subject: profiles: Support the creation of profiles with version 3 manifests. * guix/profiles.scm (%manifest-format-version): New variable. (manifest->gexp): Add optional 'format-version' parameter. [optional, entry->gexp]: Honor it. (profile-derivation): Add #:format-version parameter and honor it. ()[format-version]: New field. (profile-compiler): Honor it. * guix/build/profiles.scm (manifest-sexp->inputs+search-paths): Support both versions 3 and 4. Remove unused 'properties' variable. * tests/profiles.scm ("profile-derivation format version 3"): New test. --- guix/build/profiles.scm | 6 +++--- guix/profiles.scm | 48 +++++++++++++++++++++++++++++++++++------------- tests/profiles.scm | 28 ++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+), 16 deletions(-) (limited to 'guix/build') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 2ab76bde74..0c92f222b4 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2015, 2017-2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -162,7 +162,7 @@ search path specifications." (begin body ...)))) (match manifest ;this must match 'manifest->gexp' - (('manifest ('version 4) + (('manifest ('version (or 3 4)) ('packages (entries ...))) (let loop ((entries entries) (inputs '()) @@ -170,7 +170,7 @@ search path specifications." (match entries (((name version output item fields ...) . rest) (let ((paths search-paths)) - (let-fields fields (propagated-inputs search-paths properties) + (let-fields fields (propagated-inputs search-paths) (loop (append rest propagated-inputs) ;breadth-first traversal (cons item inputs) (append search-paths paths))))) diff --git a/guix/profiles.scm b/guix/profiles.scm index a21cc432dc..d1dfa13e98 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -452,12 +452,23 @@ denoting a specific output of a package." packages) manifest-entry=?))) -(define (manifest->gexp manifest) - "Return a representation of MANIFEST as a gexp." +(define %manifest-format-version + ;; The current manifest format version. + 4) + +(define* (manifest->gexp manifest #:optional + (format-version %manifest-format-version)) + "Return a representation in FORMAT-VERSION of MANIFEST as a gexp." (define (optional name value) - (if (null? value) - #~() - #~((#$name #$value)))) + (match format-version + (4 + (if (null? value) + #~() + #~((#$name #$value)))) + (3 + (match name + ('properties #~((#$name #$@value))) + (_ #~((#$name #$value))))))) (define (entry->gexp entry) ;; Maintain in state monad a vhash of visited entries, indexed by their @@ -467,10 +478,11 @@ denoting a specific output of a package." ;; the presence of propagated inputs, where we could otherwise end up ;; repeating large trees. (mlet %state-monad ((visited (current-state))) - (if (match (vhash-assq (manifest-entry-item entry) visited) - ((_ . previous-entry) - (manifest-entry=? previous-entry entry)) - (#f #f)) + (if (and (= format-version 4) + (match (vhash-assq (manifest-entry-item entry) visited) + ((_ . previous-entry) + (manifest-entry=? previous-entry entry)) + (#f #f))) (return #~(repeated #$(manifest-entry-name entry) #$(manifest-entry-version entry) (ungexp (manifest-entry-item entry) @@ -500,9 +512,14 @@ denoting a specific output of a package." search-paths)) #$@(optional 'properties properties)))))))))) + (unless (memq format-version '(3 4)) + (raise (formatted-message + (G_ "cannot emit manifests formatted as version ~a") + format-version))) + (match manifest (($ (entries ...)) - #~(manifest (version 4) + #~(manifest (version #$format-version) (packages #$(run-with-state (mapm %state-monad entry->gexp entries) vlist-null)))))) @@ -1883,6 +1900,7 @@ MANIFEST." (allow-unsupported-packages? #f) (allow-collisions? #f) (relative-symlinks? #f) + (format-version %manifest-format-version) system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by @@ -1968,7 +1986,7 @@ are cross-built for TARGET." #+(if locales? set-utf8-locale #t) - (build-profile #$output '#$(manifest->gexp manifest) + (build-profile #$output '#$(manifest->gexp manifest format-version) #:extra-inputs '#$extra-inputs #:symlink #$(if relative-symlinks? #~symlink-relative @@ -2007,19 +2025,23 @@ are cross-built for TARGET." (allow-collisions? profile-allow-collisions? ;Boolean (default #f)) (relative-symlinks? profile-relative-symlinks? ;Boolean - (default #f))) + (default #f)) + (format-version profile-format-version ;integer + (default %manifest-format-version))) (define-gexp-compiler (profile-compiler (profile ) system target) "Compile PROFILE to a derivation." (match profile (($ name manifest hooks - locales? allow-collisions? relative-symlinks?) + locales? allow-collisions? relative-symlinks? + format-version) (profile-derivation manifest #:name name #:hooks hooks #:locales? locales? #:allow-collisions? allow-collisions? #:relative-symlinks? relative-symlinks? + #:format-version format-version #:system system #:target target)))) (define* (profile-search-paths profile diff --git a/tests/profiles.scm b/tests/profiles.scm index f002dfc5e4..7bed946bf3 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -286,6 +286,34 @@ (string=? (dirname (readlink bindir)) (derivation->output-path guile)))))) +(test-assertm "profile-derivation format version 3" + ;; Make sure we can create and read a version 3 manifest. + (mlet* %store-monad + ((entry -> (package->manifest-entry %bootstrap-guile + #:properties '((answer . 42)))) + (manifest -> (manifest (list entry))) + (drv1 (profile-derivation manifest + #:format-version 3 ;old version + #:hooks '() + #:locales? #f)) + (drv2 (profile-derivation manifest + #:hooks '() + #:locales? #f)) + (profile1 -> (derivation->output-path drv1)) + (profile2 -> (derivation->output-path drv2)) + (_ (built-derivations (list drv1 drv2)))) + (return (let ((manifest1 (profile-manifest profile1)) + (manifest2 (profile-manifest profile2))) + (match (manifest-entries manifest1) + ((entry1) + (match (manifest-entries manifest2) + ((entry2) + (and (manifest-entry=? entry1 entry2) + (equal? (manifest-entry-properties entry1) + '((answer . 42))) + (equal? (manifest-entry-properties entry2) + '((answer . 42)))))))))))) + (test-assertm "profile-derivation, ordering & collisions" ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure ;; ENTRY1 "wins" over ENTRY2. See . -- cgit v1.2.3