From: "Ludovic Courtès" <ludo@gnu.org>
To: 55499@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: bug#55499: [PATCH 3/3] squash! profiles: Make all entry fields optional.
Date: Tue, 31 May 2022 18:09:16 +0200 [thread overview]
Message-ID: <20220531160916.21508-4-ludo@gnu.org> (raw)
In-Reply-To: <20220531160916.21508-1-ludo@gnu.org>
This is meant to be squashed with the previous patch.
This makes the 'search-paths' and 'propagated-inputs' fields of each
entry optional, shaving a bit more space and reading time, down to 180K
instead of 192K.
* guix/build/profiles.scm (manifest-sexp->inputs+search-paths)[let-fields]:
New macro.
Use it.
* guix/profiles.scm (manifest->gexp)[optional]: New procedure. Use it.
[sexp->manifest-entry]: Rename to...
[sexp->manifest-entry/v3]: ... this.
---
guix/build/profiles.scm | 28 ++++++++--
guix/profiles.scm | 120 ++++++++++++++++++++++++++--------------
2 files changed, 100 insertions(+), 48 deletions(-)
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index c4460f624b..2ab76bde74 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -149,6 +149,18 @@ (define (manifest-sexp->inputs+search-paths manifest)
"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 4)
('packages (entries ...)))
@@ -156,12 +168,12 @@ (define (manifest-sexp->inputs+search-paths manifest)
(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))
(()
@@ -214,4 +226,8 @@ (define manifest-file
;; 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
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 44ff37e75b..d694ac07da 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -454,6 +454,11 @@ (define (inferior->entry)
(define (manifest->gexp manifest)
"Return a representation of MANIFEST as a gexp."
+ (define (optional name value)
+ (if (null? value)
+ #~()
+ #~((#$name #$value))))
+
(define (entry->gexp entry)
;; Maintain in state monad a vhash of visited entries, indexed by their
;; item, usually package objects (we cannot use the entry itself as an
@@ -477,24 +482,22 @@ (define (entry->gexp entry)
(return
(match entry
(($ <manifest-entry> name version output (? string? path)
- (_deps ...) (search-paths ...) _ (properties ...))
+ (_ ...) (search-paths ...) _ (properties ...))
#~(#$name #$version #$output #$path
- (propagated-inputs #$deps)
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties)))))
+ #$@(optional 'propagated-inputs deps)
+ #$@(optional 'search-paths
+ (map search-path-specification->sexp
+ search-paths))
+ #$@(optional 'properties properties)))
(($ <manifest-entry> name version output package
(_deps ...) (search-paths ...) _ (properties ...))
#~(#$name #$version #$output
(ungexp package (or output "out"))
- (propagated-inputs #$deps)
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties))))))))))))
+ #$@(optional 'propagated-inputs deps)
+ #$@(optional 'search-paths
+ (map search-path-specification->sexp
+ search-paths))
+ #$@(optional 'properties properties))))))))))
(match manifest
(($ <manifest> (entries ...))
@@ -542,6 +545,40 @@ (define (infer-dependency item parent)
(item item)
(parent parent))))
+ (define* (sexp->manifest-entry/v3 sexp #:optional (parent (delay #f)))
+ (match sexp
+ ((name version output path
+ ('propagated-inputs deps)
+ ('search-paths search-paths)
+ extra-stuff ...)
+ ;; For each of DEPS, keep a promise pointing to ENTRY.
+ (letrec* ((deps* (map (cut sexp->manifest-entry/v3 <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent)
+ (properties (or (assoc-ref extra-stuff 'properties)
+ '())))))
+ entry))))
+
+ (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 ...))))
+
(define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
(match sexp
(('repeated name version path)
@@ -556,32 +593,29 @@ (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
sexp)))
((_ . entry)
(return entry)))))
- ((name version output path
- ('propagated-inputs deps)
- ('search-paths search-paths)
- extra-stuff ...)
- (mlet* %state-monad
- ((entry -> #f)
- (deps* (mapm %state-monad
- (cut sexp->manifest-entry <> (delay entry))
- deps))
- (visited (current-state))
- (key -> (list name version path)))
- (set! entry ;XXX: emulate 'letrec*'
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps*)
- (search-paths (map sexp->search-path-specification
- search-paths))
- (parent parent)
- (properties (or (assoc-ref extra-stuff 'properties)
- '()))))
- (mbegin %state-monad
- (set-current-state (vhash-cons key entry visited))
- (return entry))))))
+ ((name version output path fields ...)
+ (let-fields fields (propagated-inputs search-paths properties)
+ (mlet* %state-monad
+ ((entry -> #f)
+ (deps (mapm %state-monad
+ (cut sexp->manifest-entry <> (delay entry))
+ propagated-inputs))
+ (visited (current-state))
+ (key -> (list name version path)))
+ (set! entry ;XXX: emulate 'letrec*'
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent)
+ (properties properties)))
+ (mbegin %state-monad
+ (set-current-state (vhash-cons key entry visited))
+ (return entry)))))))
(match sexp
(('manifest ('version 0)
@@ -649,9 +683,7 @@ (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
;; Version 3 represents DEPS as full-blown manifest entries.
(('manifest ('version 3 minor-version ...)
('packages (entries ...)))
- (manifest (run-with-state
- (mapm %state-monad sexp->manifest-entry entries)
- vlist-null)))
+ (manifest (map sexp->manifest-entry/v3 entries)))
;; Version 4 deduplicates repeated entries, as can happen with deep
;; propagated input trees.
@@ -2368,4 +2400,8 @@ (define (user-friendly-profile profile)
%known-shorthand-profiles)
profile))
+;;; Local Variables:
+;;; eval: (put 'let-fields 'scheme-indent-function 2)
+;;; End:
+
;;; profiles.scm ends here
--
2.36.1
next prev parent reply other threads:[~2022-05-31 16:21 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-05-18 13:53 bug#55499: excessively large manifests due to propagation Ricardo Wurmus
2022-05-24 15:30 ` Ludovic Courtès
2022-05-25 4:35 ` Ricardo Wurmus
2022-05-31 16:09 ` bug#55499: [PATCH 0/3] Make 'manifest' files more compact Ludovic Courtès
2022-05-31 16:09 ` bug#55499: [PATCH 1/3] tests: Augment profile collision test Ludovic Courtès
2022-05-31 16:09 ` bug#55499: [PATCH 2/3] profiles: Do not repeat entries in 'manifest' file Ludovic Courtès
2022-05-31 17:35 ` Maxime Devos
2022-06-01 9:38 ` Ludovic Courtès
2022-05-31 16:09 ` Ludovic Courtès [this message]
2022-06-14 7:06 ` bug#55499: excessively large manifests due to propagation Ludovic Courtès
2022-07-01 21:54 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20220531160916.21508-4-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=55499@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).