From b6907f76040fa524110a503848ed9b9d9b19dfaf Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Sat, 4 Sep 2021 18:10:32 +0200 Subject: [PATCH v2 8/9] 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*, valid-path?*): New procedures. --- guix/gexp.scm | 41 ++++++++++++++++++++++++++++++++++------- 1 file changed, 34 insertions(+), 7 deletions(-) diff --git a/guix/gexp.scm b/guix/gexp.scm index c69e4aa299..6a6d130110 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -528,16 +528,43 @@ appears." 'system-error' exception is raised if FILE could not be found." (force (%local-file-absolute-file-name file))) +(define add-temp-root* (store-lift add-temp-root)) +(define valid-path?* (store-lift valid-path?)) + (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 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?))) + (mbegin %store-monad + ;; Tell the GC that PATH will be used, such that it won't + ;; be deleted. + (add-temp-root* path) + ;; 'add-temp-root*' doesn't thow an error if the store item + ;; does not exist, so we need to check if PATH actually exists. + (mlet %store-monad + ((valid? (valid-path?* path))) + (if valid? + (return path) + ;; If it has been removed, fall-back interning. + (intern))))) + ;; If PATH does not yet exist, fall back to interning. + (intern)))))) (define-record-type (%plain-file name content references) -- 2.33.0