From d359fefabf2831e42aea6edf646a9e0373be5d0f Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 4 Sep 2021 18:10:32 +0200
Subject: [PATCH 10/10] gexp: Do not intern if the file is already in the
store.
* guix/gexp.scm (local-file-compiler): When the file is already in the
store, re-use the fixed output path instead of interning the file
again.
* guix/gexp.scm (add-temp-root-and-valid-path?*): New procedure.
---
guix/gexp.scm | 32 +++++++++++++++++++++++++-------
1 file changed, 25 insertions(+), 7 deletions(-)
@@ -528,16 +528,34 @@ appears."
'system-error' exception is raised if FILE could not be found."
(force (%local-file-absolute-file-name file)))
+(define add-temp-root-and-valid-path?* (store-lift add-temp-root-and-valid-path?))
+
(define-gexp-compiler (local-file-compiler (file <local-file>) system target)
;; "Compile" FILE by adding it to the store.
(match file
- (($ <local-file> file (= force absolute) name sha256 recursive? select?)
- ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing
- ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling
- ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would
- ;; just throw an error, both of which are inconvenient.
- (interned-file absolute name
- #:recursive? recursive? #:select? select?))))
+ ;; Delay computing the absolute file name until 'intern', as this
+ ;; might be a relatively expensive computation (e.g. if search-patch
+ ;; is used), especially on a spinning disk.
+ (($ <local-file> file absolute-promise name sha256 recursive? select?)
+ (let ()
+ (define (intern)
+ ;; Canonicalize FILE so that if it's a symlink, it is resolved.
+ ;; Failing to do that, when RECURSIVE? is #t, we could end up creating
+ ;; a dangling symlink in the store, and when RECURSIVE? is #f
+ ;; 'add-to-store' would just throw an error, both of which are
+ ;; inconvenient.
+ (interned-file (force absolute-promise) name
+ #:recursive? recursive? #:select? select?))
+ ;; If the hash is known in advance and the store already has the
+ ;; item, there is no need to intern the file.
+ (if sha256
+ (let ((path (fixed-output-path name sha256 #:recursive? recursive?)))
+ (mlet %store-monad ((valid? (add-temp-root-and-valid-path?* path)))
+ (if valid?
+ (return path)
+ (intern))))
+ ;; If PATH does not yet exist, fall back to interning.
+ (intern))))))
(define-record-type <plain-file>
(%plain-file name content references)
--
2.33.0