From 0fc54bdd9ccc9729fff54f5935a552e5e608a1d0 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Sat, 4 Sep 2021 18:10:32 +0200 Subject: [PATCH 6/6] 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 | 38 +++++++++++++++++++++++++++++++------- 1 file changed, 31 insertions(+), 7 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index c69e4aa299..da1e918801 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -531,13 +531,37 @@ appears." (define-gexp-compiler (local-file-compiler (file ) system target) ;; "Compile" FILE by adding it to the store. (match 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. + (($ 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 sha256 + (let ((path (fixed-output-path name sha256 #:recursive? recursive?))) + ;; If the hash is known in advance and the store already has the + ;; item, there is no need to intern the file. + (if (file-exists? path) + (mbegin %store-monad + ;; Tell the GC that PATH will be used, such that it won't + ;; be deleted. + ((store-lift add-temp-root) path) + ;; The GC could have deleted the item before add-temp-root + ;; completed, so check again if PATH exists. + (if (file-exists? path) + (return path) + ;; If it has been removed, fall-back interning. + (intern))) + ;; If PATH does not yet exist, fall back to interning. + (intern))) + (intern)))))) (define-record-type (%plain-file name content references) -- 2.33.0