[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/06: guix build, archive, graph: Disable absolute file port name canon
|
From: |
guix-commits |
|
Subject: |
02/06: guix build, archive, graph: Disable absolute file port name canonicalization. |
|
Date: |
Fri, 24 Jan 2020 18:16:26 -0500 (EST) |
civodul pushed a commit to branch master
in repository guix.
commit 09238d618a511de80de189ff3ff18bfa0f280bb9
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Jan 24 18:13:38 2020 +0100
guix build, archive, graph: Disable absolute file port name
canonicalization.
This avoids an 'lstat' storm. Specifically:
./pre-inst-env strace -c guix build -nd libreoffice
goes from 1,711 to 214 'lstat' calls.
* guix/scripts/build.scm (options->things-to-build): When SPEC matches
'derivation-path?', call 'canonicalize-path'.
(guix-build): Remove 'with-fluids' for %FILE-PORT-NAME-CANONICALIZATION.
* guix/scripts/archive.scm (guix-archive): Remove 'with-fluids' for
%FILE-PORT-NAME-CANONICALIZATION.
* guix/scripts/graph.scm (guix-graph): Likewise.
---
guix/scripts/archive.scm | 65 +++++++++++------------
guix/scripts/build.scm | 131 ++++++++++++++++++++++++-----------------------
guix/scripts/graph.scm | 27 +++++-----
3 files changed, 109 insertions(+), 114 deletions(-)
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 2b4d39c..4f39920 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès
<address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès
<address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -371,36 +371,33 @@ output port."
(cons line result)))))
(with-error-handling
- ;; Ask for absolute file names so that .drv file names passed from the
- ;; user to 'read-derivation' are absolute when it returns.
- (with-fluids ((%file-port-name-canonicalization 'absolute))
- (let ((opts (parse-command-line args %options (list %default-options))))
- (parameterize ((%graft? (assoc-ref opts 'graft?)))
- (cond ((assoc-ref opts 'generate-key)
- =>
- generate-key-pair)
- ((assoc-ref opts 'authorize)
- (authorize-key))
- (else
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (with-store store
- (set-build-options-from-command-line store opts)
- (cond ((assoc-ref opts 'export)
- (export-from-store store opts))
- ((assoc-ref opts 'import)
- (import-paths store (current-input-port)))
- ((assoc-ref opts 'missing)
- (let* ((files (lines (current-input-port)))
- (missing (remove (cut valid-path? store <>)
- files)))
- (format #t "~{~a~%~}" missing)))
- ((assoc-ref opts 'list)
- (list-contents (current-input-port)))
- ((assoc-ref opts 'extract)
- =>
- (lambda (target)
- (restore-file (current-input-port) target)))
- (else
- (leave
- (G_ "either '--export' or '--import' \
-must be specified~%")))))))))))))
+ (let ((opts (parse-command-line args %options (list %default-options))))
+ (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (cond ((assoc-ref opts 'generate-key)
+ =>
+ generate-key-pair)
+ ((assoc-ref opts 'authorize)
+ (authorize-key))
+ (else
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ (cond ((assoc-ref opts 'export)
+ (export-from-store store opts))
+ ((assoc-ref opts 'import)
+ (import-paths store (current-input-port)))
+ ((assoc-ref opts 'missing)
+ (let* ((files (lines (current-input-port)))
+ (missing (remove (cut valid-path? store <>)
+ files)))
+ (format #t "~{~a~%~}" missing)))
+ ((assoc-ref opts 'list)
+ (list-contents (current-input-port)))
+ ((assoc-ref opts 'extract)
+ =>
+ (lambda (target)
+ (restore-file (current-input-port) target)))
+ (else
+ (leave
+ (G_ "either '--export' or '--import' \
+must be specified~%"))))))))))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index bf307d1..f054fc2 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -809,7 +809,11 @@ build---packages, gexps, derivations, and so on."
(cond ((derivation-path? spec)
(catch 'system-error
(lambda ()
- (list (read-derivation-from-file spec)))
+ ;; Ask for absolute file names so that .drv file
+ ;; names passed from the user to 'read-derivation'
+ ;; are absolute when it returns.
+ (let ((spec (canonicalize-path spec)))
+ (list (read-derivation-from-file spec))))
(lambda args
;; Non-existent .drv files can be substituted down
;; the road, so don't error out.
@@ -927,67 +931,64 @@ needed."
(list %default-options)))
(with-error-handling
- ;; Ask for absolute file names so that .drv file names passed from the
- ;; user to 'read-derivation' are absolute when it returns.
- (with-fluids ((%file-port-name-canonicalization 'absolute))
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (with-store store
- ;; Set the build options before we do anything else.
- (set-build-options-from-command-line store opts)
-
- (parameterize ((current-terminal-columns (terminal-columns)))
- (let* ((mode (assoc-ref opts 'build-mode))
- (drv (options->derivations store opts))
- (urls (map (cut string-append <> "/log")
- (if (assoc-ref opts 'substitutes?)
- (or (assoc-ref opts 'substitute-urls)
- ;; XXX: This does not necessarily match
the
- ;; daemon's substitute URLs.
- %default-substitute-urls)
- '())))
- (items (filter-map (match-lambda
- (('argument . (? store-path? file))
- ;; If FILE is a .drv that's not in
- ;; store, keep it so that it can be
- ;; substituted.
- (and (or (not (derivation-path? file))
- (not (file-exists? file)))
- file))
- (_ #f))
- opts))
- (roots (filter-map (match-lambda
- (('gc-root . root) root)
- (_ #f))
- opts)))
-
- (unless (or (assoc-ref opts 'log-file?)
- (assoc-ref opts 'derivations-only?))
- (show-what-to-build store drv
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? (assoc-ref opts 'dry-run?)
- #:mode mode))
-
- (cond ((assoc-ref opts 'log-file?)
- ;; Pass 'show-build-log' the output file names, not the
- ;; derivation file names, because there can be several
- ;; derivations leading to the same output.
- (for-each (cut show-build-log store <> urls)
- (delete-duplicates
- (append (map derivation->output-path drv)
- items))))
- ((assoc-ref opts 'derivations-only?)
- (format #t "~{~a~%~}" (map derivation-file-name drv))
- (for-each (cut register-root store <> <>)
- (map (compose list derivation-file-name) drv)
- roots))
- ((not (assoc-ref opts 'dry-run?))
- (and (build-derivations store (append drv items)
- mode)
- (for-each show-derivation-outputs drv)
- (for-each (cut register-root store <> <>)
- (map (lambda (drv)
- (map cdr
- (derivation->output-paths
drv)))
- drv)
- roots)))))))))))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (with-store store
+ ;; Set the build options before we do anything else.
+ (set-build-options-from-command-line store opts)
+
+ (parameterize ((current-terminal-columns (terminal-columns)))
+ (let* ((mode (assoc-ref opts 'build-mode))
+ (drv (options->derivations store opts))
+ (urls (map (cut string-append <> "/log")
+ (if (assoc-ref opts 'substitutes?)
+ (or (assoc-ref opts 'substitute-urls)
+ ;; XXX: This does not necessarily match
the
+ ;; daemon's substitute URLs.
+ %default-substitute-urls)
+ '())))
+ (items (filter-map (match-lambda
+ (('argument . (? store-path? file))
+ ;; If FILE is a .drv that's not in
+ ;; store, keep it so that it can be
+ ;; substituted.
+ (and (or (not (derivation-path? file))
+ (not (file-exists? file)))
+ file))
+ (_ #f))
+ opts))
+ (roots (filter-map (match-lambda
+ (('gc-root . root) root)
+ (_ #f))
+ opts)))
+
+ (unless (or (assoc-ref opts 'log-file?)
+ (assoc-ref opts 'derivations-only?))
+ (show-what-to-build store drv
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? (assoc-ref opts 'dry-run?)
+ #:mode mode))
+
+ (cond ((assoc-ref opts 'log-file?)
+ ;; Pass 'show-build-log' the output file names, not the
+ ;; derivation file names, because there can be several
+ ;; derivations leading to the same output.
+ (for-each (cut show-build-log store <> urls)
+ (delete-duplicates
+ (append (map derivation->output-path drv)
+ items))))
+ ((assoc-ref opts 'derivations-only?)
+ (format #t "~{~a~%~}" (map derivation-file-name drv))
+ (for-each (cut register-root store <> <>)
+ (map (compose list derivation-file-name) drv)
+ roots))
+ ((not (assoc-ref opts 'dry-run?))
+ (and (build-derivations store (append drv items)
+ mode)
+ (for-each show-derivation-outputs drv)
+ (for-each (cut register-root store <> <>)
+ (map (lambda (drv)
+ (map cdr
+ (derivation->output-paths drv)))
+ drv)
+ roots))))))))))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 53f407b..fca1e37 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès
<address@hidden>
;;; Copyright © 2019 Simon Tournier <address@hidden>
;;;
;;; This file is part of GNU Guix.
@@ -552,20 +552,17 @@ Emit a representation of the dependency graph of
PACKAGE...\n"))
(read/eval-package-expression exp)))
(_ #f))
opts)))
- ;; Ask for absolute file names so that .drv file names passed from the
- ;; user to 'read-derivation' are absolute when it returns.
- (with-fluids ((%file-port-name-canonicalization 'absolute))
- (run-with-store store
- ;; XXX: Since grafting can trigger unsolicited builds, disable it.
- (mlet %store-monad ((_ (set-grafting #f))
- (nodes (mapm %store-monad
- (node-type-convert type)
- items)))
- (export-graph (concatenate nodes)
- (current-output-port)
- #:node-type type
- #:backend backend))
- #:system (assq-ref opts 'system))))))
+ (run-with-store store
+ ;; XXX: Since grafting can trigger unsolicited builds, disable it.
+ (mlet %store-monad ((_ (set-grafting #f))
+ (nodes (mapm %store-monad
+ (node-type-convert type)
+ items)))
+ (export-graph (concatenate nodes)
+ (current-output-port)
+ #:node-type type
+ #:backend backend))
+ #:system (assq-ref opts 'system)))))
#t)
;;; graph.scm ends here
- branch master updated (2aa1e76 -> 0ef7e44), guix-commits, 2020/01/24
- 01/06: ui: Do not display error messages with bare format strings., guix-commits, 2020/01/24
- 03/06: serialization: 'read-byte-string' makes a single read(2) call., guix-commits, 2020/01/24
- 05/06: gnu: python-pygments: Update to 2.5.2., guix-commits, 2020/01/24
- 02/06: guix build, archive, graph: Disable absolute file port name canonicalization.,
guix-commits <=
- 06/06: gnu: httpie: Update to 2.0.0., guix-commits, 2020/01/24
- 04/06: gnu: guile-ics: Add "guile3.0-ics" variant., guix-commits, 2020/01/24