mirror of
https://https.git.savannah.gnu.org/git/guix.git/
synced 2025-07-15 19:40:46 +02:00
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
|
;;; 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.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -371,36 +371,33 @@ output port."
|
||||||
(cons line result)))))
|
(cons line result)))))
|
||||||
|
|
||||||
(with-error-handling
|
(with-error-handling
|
||||||
;; Ask for absolute file names so that .drv file names passed from the
|
(let ((opts (parse-command-line args %options (list %default-options))))
|
||||||
;; user to 'read-derivation' are absolute when it returns.
|
(parameterize ((%graft? (assoc-ref opts 'graft?)))
|
||||||
(with-fluids ((%file-port-name-canonicalization 'absolute))
|
(cond ((assoc-ref opts 'generate-key)
|
||||||
(let ((opts (parse-command-line args %options (list %default-options))))
|
=>
|
||||||
(parameterize ((%graft? (assoc-ref opts 'graft?)))
|
generate-key-pair)
|
||||||
(cond ((assoc-ref opts 'generate-key)
|
((assoc-ref opts 'authorize)
|
||||||
=>
|
(authorize-key))
|
||||||
generate-key-pair)
|
(else
|
||||||
((assoc-ref opts 'authorize)
|
(with-status-verbosity (assoc-ref opts 'verbosity)
|
||||||
(authorize-key))
|
(with-store store
|
||||||
(else
|
(set-build-options-from-command-line store opts)
|
||||||
(with-status-verbosity (assoc-ref opts 'verbosity)
|
(cond ((assoc-ref opts 'export)
|
||||||
(with-store store
|
(export-from-store store opts))
|
||||||
(set-build-options-from-command-line store opts)
|
((assoc-ref opts 'import)
|
||||||
(cond ((assoc-ref opts 'export)
|
(import-paths store (current-input-port)))
|
||||||
(export-from-store store opts))
|
((assoc-ref opts 'missing)
|
||||||
((assoc-ref opts 'import)
|
(let* ((files (lines (current-input-port)))
|
||||||
(import-paths store (current-input-port)))
|
(missing (remove (cut valid-path? store <>)
|
||||||
((assoc-ref opts 'missing)
|
files)))
|
||||||
(let* ((files (lines (current-input-port)))
|
(format #t "~{~a~%~}" missing)))
|
||||||
(missing (remove (cut valid-path? store <>)
|
((assoc-ref opts 'list)
|
||||||
files)))
|
(list-contents (current-input-port)))
|
||||||
(format #t "~{~a~%~}" missing)))
|
((assoc-ref opts 'extract)
|
||||||
((assoc-ref opts 'list)
|
=>
|
||||||
(list-contents (current-input-port)))
|
(lambda (target)
|
||||||
((assoc-ref opts 'extract)
|
(restore-file (current-input-port) target)))
|
||||||
=>
|
(else
|
||||||
(lambda (target)
|
(leave
|
||||||
(restore-file (current-input-port) target)))
|
(G_ "either '--export' or '--import' \
|
||||||
(else
|
must be specified~%"))))))))))))
|
||||||
(leave
|
|
||||||
(G_ "either '--export' or '--import' \
|
|
||||||
must be specified~%")))))))))))))
|
|
||||||
|
|
|
||||||
|
|
@ -809,7 +809,11 @@ build---packages, gexps, derivations, and so on."
|
||||||
(cond ((derivation-path? spec)
|
(cond ((derivation-path? spec)
|
||||||
(catch 'system-error
|
(catch 'system-error
|
||||||
(lambda ()
|
(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
|
(lambda args
|
||||||
;; Non-existent .drv files can be substituted down
|
;; Non-existent .drv files can be substituted down
|
||||||
;; the road, so don't error out.
|
;; the road, so don't error out.
|
||||||
|
|
@ -927,67 +931,64 @@ needed."
|
||||||
(list %default-options)))
|
(list %default-options)))
|
||||||
|
|
||||||
(with-error-handling
|
(with-error-handling
|
||||||
;; Ask for absolute file names so that .drv file names passed from the
|
(with-status-verbosity (assoc-ref opts 'verbosity)
|
||||||
;; user to 'read-derivation' are absolute when it returns.
|
(with-store store
|
||||||
(with-fluids ((%file-port-name-canonicalization 'absolute))
|
;; Set the build options before we do anything else.
|
||||||
(with-status-verbosity (assoc-ref opts 'verbosity)
|
(set-build-options-from-command-line store opts)
|
||||||
(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)))
|
(parameterize ((current-terminal-columns (terminal-columns)))
|
||||||
(let* ((mode (assoc-ref opts 'build-mode))
|
(let* ((mode (assoc-ref opts 'build-mode))
|
||||||
(drv (options->derivations store opts))
|
(drv (options->derivations store opts))
|
||||||
(urls (map (cut string-append <> "/log")
|
(urls (map (cut string-append <> "/log")
|
||||||
(if (assoc-ref opts 'substitutes?)
|
(if (assoc-ref opts 'substitutes?)
|
||||||
(or (assoc-ref opts 'substitute-urls)
|
(or (assoc-ref opts 'substitute-urls)
|
||||||
;; XXX: This does not necessarily match the
|
;; XXX: This does not necessarily match the
|
||||||
;; daemon's substitute URLs.
|
;; daemon's substitute URLs.
|
||||||
%default-substitute-urls)
|
%default-substitute-urls)
|
||||||
'())))
|
'())))
|
||||||
(items (filter-map (match-lambda
|
(items (filter-map (match-lambda
|
||||||
(('argument . (? store-path? file))
|
(('argument . (? store-path? file))
|
||||||
;; If FILE is a .drv that's not in
|
;; If FILE is a .drv that's not in
|
||||||
;; store, keep it so that it can be
|
;; store, keep it so that it can be
|
||||||
;; substituted.
|
;; substituted.
|
||||||
(and (or (not (derivation-path? file))
|
(and (or (not (derivation-path? file))
|
||||||
(not (file-exists? file)))
|
(not (file-exists? file)))
|
||||||
file))
|
file))
|
||||||
(_ #f))
|
(_ #f))
|
||||||
opts))
|
opts))
|
||||||
(roots (filter-map (match-lambda
|
(roots (filter-map (match-lambda
|
||||||
(('gc-root . root) root)
|
(('gc-root . root) root)
|
||||||
(_ #f))
|
(_ #f))
|
||||||
opts)))
|
opts)))
|
||||||
|
|
||||||
(unless (or (assoc-ref opts 'log-file?)
|
(unless (or (assoc-ref opts 'log-file?)
|
||||||
(assoc-ref opts 'derivations-only?))
|
(assoc-ref opts 'derivations-only?))
|
||||||
(show-what-to-build store drv
|
(show-what-to-build store drv
|
||||||
#:use-substitutes?
|
#:use-substitutes?
|
||||||
(assoc-ref opts 'substitutes?)
|
(assoc-ref opts 'substitutes?)
|
||||||
#:dry-run? (assoc-ref opts 'dry-run?)
|
#:dry-run? (assoc-ref opts 'dry-run?)
|
||||||
#:mode mode))
|
#:mode mode))
|
||||||
|
|
||||||
(cond ((assoc-ref opts 'log-file?)
|
(cond ((assoc-ref opts 'log-file?)
|
||||||
;; Pass 'show-build-log' the output file names, not the
|
;; Pass 'show-build-log' the output file names, not the
|
||||||
;; derivation file names, because there can be several
|
;; derivation file names, because there can be several
|
||||||
;; derivations leading to the same output.
|
;; derivations leading to the same output.
|
||||||
(for-each (cut show-build-log store <> urls)
|
(for-each (cut show-build-log store <> urls)
|
||||||
(delete-duplicates
|
(delete-duplicates
|
||||||
(append (map derivation->output-path drv)
|
(append (map derivation->output-path drv)
|
||||||
items))))
|
items))))
|
||||||
((assoc-ref opts 'derivations-only?)
|
((assoc-ref opts 'derivations-only?)
|
||||||
(format #t "~{~a~%~}" (map derivation-file-name drv))
|
(format #t "~{~a~%~}" (map derivation-file-name drv))
|
||||||
(for-each (cut register-root store <> <>)
|
(for-each (cut register-root store <> <>)
|
||||||
(map (compose list derivation-file-name) drv)
|
(map (compose list derivation-file-name) drv)
|
||||||
roots))
|
roots))
|
||||||
((not (assoc-ref opts 'dry-run?))
|
((not (assoc-ref opts 'dry-run?))
|
||||||
(and (build-derivations store (append drv items)
|
(and (build-derivations store (append drv items)
|
||||||
mode)
|
mode)
|
||||||
(for-each show-derivation-outputs drv)
|
(for-each show-derivation-outputs drv)
|
||||||
(for-each (cut register-root store <> <>)
|
(for-each (cut register-root store <> <>)
|
||||||
(map (lambda (drv)
|
(map (lambda (drv)
|
||||||
(map cdr
|
(map cdr
|
||||||
(derivation->output-paths drv)))
|
(derivation->output-paths drv)))
|
||||||
drv)
|
drv)
|
||||||
roots)))))))))))
|
roots))))))))))
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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>
|
;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; 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)))
|
(read/eval-package-expression exp)))
|
||||||
(_ #f))
|
(_ #f))
|
||||||
opts)))
|
opts)))
|
||||||
;; Ask for absolute file names so that .drv file names passed from the
|
(run-with-store store
|
||||||
;; user to 'read-derivation' are absolute when it returns.
|
;; XXX: Since grafting can trigger unsolicited builds, disable it.
|
||||||
(with-fluids ((%file-port-name-canonicalization 'absolute))
|
(mlet %store-monad ((_ (set-grafting #f))
|
||||||
(run-with-store store
|
(nodes (mapm %store-monad
|
||||||
;; XXX: Since grafting can trigger unsolicited builds, disable it.
|
(node-type-convert type)
|
||||||
(mlet %store-monad ((_ (set-grafting #f))
|
items)))
|
||||||
(nodes (mapm %store-monad
|
(export-graph (concatenate nodes)
|
||||||
(node-type-convert type)
|
(current-output-port)
|
||||||
items)))
|
#:node-type type
|
||||||
(export-graph (concatenate nodes)
|
#:backend backend))
|
||||||
(current-output-port)
|
#:system (assq-ref opts 'system)))))
|
||||||
#:node-type type
|
|
||||||
#:backend backend))
|
|
||||||
#:system (assq-ref opts 'system))))))
|
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
;;; graph.scm ends here
|
;;; graph.scm ends here
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue