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.

3 files changed, 109 insertions, 114 deletions

diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 2b4d39c7b8..4f39920fe7 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 <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~%"))))))))))))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index bf307d1421..f054fc2bce 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 53f407b2fc..fca1e3777c 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 <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