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.
This commit is contained in:
Ludovic Courtès
parent
a07d5e558b
commit
09238d618a
3 changed files with 106 additions and 111 deletions
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; 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~%"))))))))))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(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)))
|
||||
(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))
|
||||
(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)))))))))))
|
||||
(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))))))))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
|
||||
;;;
|
||||
;;; 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
|
||||
|
|
|
|||
Reference in a new issue