Subject: [PATCH v4] Optimise search-patch (reducing I/O)

From: Ludovic Courtès <[email-masked]>
Date: Tue, 21 Sep 2021 18:55:27 +0200

Hi!

I took the liberty to reopen this patch because there were good ideas
IMO.  I’m sorry if my many questions and lack of responsiveness came out
as a suggestion that this approach wasn’t good.

Ludovic Courtès <[email-masked]> skribis:

>> +;; repeated 'stat' calls.  Allow computing the hash of the file in advance,
>> +;; to avoid having to send the file to the daemon when it is already interned
>> +;; in the store.
>>  (define-record-type <local-file>
>> -  (%%local-file file absolute name recursive? select?)
>> +  (%%local-file file absolute name sha256 recursive? select?)
>>    local-file?
>>    (file       local-file-file)                    ;string
>>    (absolute   %local-file-absolute-file-name)     ;promise string
>>    (name       local-file-name)                    ;string
>> +  (sha256     local-file-sha256)                  ;sha256 bytevector | #f
>
> Could we store the result of ‘fixed-output-path’ rather than the SHA256,
> while we’re at it?

I tried that with the patch below, roughly taking the same approach as
your patch series, but somewhat simplified, mostly so I could
experiment.

I changed just a few files to use the new ‘local-patches’ instead of
‘search-patches’ (I thought it might make sense to introduce a new
macro, to make it clear that ‘%package-module-path’ is not used at all).

The end result is that it works as intended :-), but it’s actually a
tiny bit slower: on a cache hit, we do 2 RPCs (add-temp-root +
valid-path?) instead of 1 (add-to-store).  The extra round-trip is more
expensive than the I/O we’re saving, at least on my laptop (with SSD; it
might be different with slower disk I/O and/or when talking to a remote
daemon, as on clusters.)

Now, this could be addressed by adding an ‘add-temp-root-if-valid’ RPC,
which would do both in one.

We can estimate the performance of that strategy by commenting out the
‘add-temp-root*’ call (thus getting a single RPC) in
‘local-file-compiler’: this time it’s slightly faster, but we’re in the
1% range on the wall-clock time of ‘guix build pigx -d --no-grafts’:

--8<---------------cut here---------------start------------->8---
$ time GUIX_DISABLE_LOCAL_FILE_CACHE=t ./pre-inst-env guix build pigx -d --no-grafts
/gnu/store/dqaknknlsw8a97xwjrhhd1g4jg71jqg7-pigx-0.0.3.drv

real	0m3.488s
user	0m3.718s
sys	0m0.132s
$ time GUIX_DISABLE_LOCAL_FILE_CACHE=t ./pre-inst-env guix build pigx -d --no-grafts
/gnu/store/dqaknknlsw8a97xwjrhhd1g4jg71jqg7-pigx-0.0.3.drv

real	0m3.501s
user	0m3.722s
sys	0m0.138s
$ time ./pre-inst-env guix build pigx -d --no-grafts
/gnu/store/dqaknknlsw8a97xwjrhhd1g4jg71jqg7-pigx-0.0.3.drv

real	0m3.437s
user	0m3.622s
sys	0m0.174s
$ time ./pre-inst-env guix build pigx -d --no-grafts
/gnu/store/dqaknknlsw8a97xwjrhhd1g4jg71jqg7-pigx-0.0.3.drv

real	0m3.492s
user	0m3.708s
sys	0m0.151s
--8<---------------cut here---------------end--------------->8---

Perhaps the gains would be a bit higher if we change all the package
files to use ‘local-patches’, but we probably can’t expect a lot more
anyway since that process is CPU-bound.

So I don’t know.  It feels like a worthy optimization, and one that’s
manageable from a maintenance viewpoint, but it buys us very little.

Thoughts?

Looking at the big picture, what I’d like to have is a package
derivation cache designed in such a way that “guix install foo” wouldn’t
even need to load any package module on a cache hit.  That’d make a
noticeable difference performance-wise, that’s another level of
complexity…  (I have a rough design in mind that we could discuss.)

Ludo’.

diff --git a/gnu/packages.scm b/gnu/packages.scm
index ccfc83dd11..4e7045e605 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2013 Mark H Weaver <[email-masked]>
 ;;; Copyright © 2014 Eric Bavier <[email-masked]>
 ;;; Copyright © 2016, 2017 Alex Kost <[email-masked]>
@@ -34,6 +34,7 @@
   #:use-module (guix profiles)
   #:use-module (guix describe)
   #:use-module (guix deprecation)
+  #:use-module (guix gexp)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (ice-9 binary-ports)
@@ -46,6 +47,7 @@
   #:use-module (srfi srfi-39)
   #:export (search-patch
             search-patches
+            local-patches
             search-auxiliary-file
             %patch-path
             %auxiliary-files-path
@@ -101,6 +103,17 @@
 FILE-NAME found in %PATCH-PATH."
   (list (search-patch file-name) ...))
 
+(define-syntax local-patches
+  (lambda (s)
+    (syntax-case s ()
+      ((_ files ...)
+       (let ((scoped (map (lambda (file)
+                            (string-append "patches/" file))
+                          (syntax->datum #'(files ...)))))
+         (with-syntax (((scoped ...) (datum->syntax #'x scoped)))
+           #`(list (local-file scoped #:recursive? #t)
+                   ...)))))))
+
 (define %distro-root-directory
   ;; Absolute file name of the module hierarchy.  Since (gnu packages …) might
   ;; live in a directory different from (guix), try to get the best match.
diff --git a/gnu/packages/base.scm b/gnu/packages/base.scm
index ea2e102c15..b449b5c2b5 100644
--- a/gnu/packages/base.scm
+++ b/gnu/packages/base.scm
@@ -106,7 +106,7 @@ command-line arguments, multiple languages, and so on.")
             (sha256
              (base32
               "1yy33kiwrxrwj2nxa4fg15bvmwyghqbs8qwkdvy5phm784f7brjq"))
-            (patches (search-patches "grep-timing-sensitive-test.patch"))))
+            (patches (local-patches "grep-timing-sensitive-test.patch"))))
    (build-system gnu-build-system)
    (native-inputs `(("perl" ,perl)))             ;some of the tests require it
    (inputs `(("pcre" ,pcre)))
@@ -187,7 +187,7 @@ implementation offers several extensions over the standard utility.")
             (sha256
              (base32
               "1n7xy657ii0sa42zx6944v2m4v9qrh6sqgmw17l3nch3y43sxlyh"))
-            (patches (search-patches "tar-skip-unreliable-tests.patch"
+            (patches (local-patches "tar-skip-unreliable-tests.patch"
                                      "tar-remove-wholesparse-check.patch"))))
    (build-system gnu-build-system)
    ;; Note: test suite requires ~1GiB of disk space.
@@ -245,7 +245,7 @@ standard utility.")
               (sha256
                (base32
                 "1zfqy4rdcy279vwn2z1kbv19dcfw25d2aqy9nzvdkq5bjzd0nqdc"))
-              (patches (search-patches "patch-hurd-path-max.patch"))))
+              (patches (local-patches "patch-hurd-path-max.patch"))))
    (build-system gnu-build-system)
    (arguments
     ;; Work around a cross-compilation bug whereby libpatch.a would provide
@@ -298,7 +298,7 @@ interactive means to merge two files.")
             (sha256
              (base32
               "16kqz9yz98dasmj70jwf5py7jk558w96w0vgp3zf9xsqk3gzpzn5"))
-            (patches (search-patches "findutils-localstatedir.patch"
+            (patches (local-patches "findutils-localstatedir.patch"
                                      "findutils-test-rwlock-threads.patch"))))
    (build-system gnu-build-system)
    (arguments
@@ -335,7 +335,7 @@ used to apply commands with arbitrarily long arguments.")
             (sha256
              (base32
               "1yjcrh5hw70c0yn8zw55pd6j51dj90anpq8mmg649ps9g3gdhn24"))
-            (patches (search-patches "coreutils-ls.patch"))))
+            (patches (local-patches "coreutils-ls.patch"))))
    (build-system gnu-build-system)
    (inputs `(("acl"  ,acl)                        ; TODO: add SELinux
              ("gmp"  ,gmp)                        ;bignums in 'expr', yay!
@@ -450,7 +450,7 @@ standard.")
             (sha256
              (base32
               "06cfqzpqsvdnsxbysl5p2fgdgxgl9y4p7scpnrfa8z2zgkjdspz0"))
-            (patches (search-patches "make-impure-dirs.patch"))))
+            (patches (local-patches "make-impure-dirs.patch"))))
    (build-system gnu-build-system)
    (native-inputs `(("pkg-config" ,pkg-config)))  ; to detect Guile
    (inputs `(("guile" ,guile-3.0)))
@@ -518,7 +518,7 @@ change.  GNU make offers many powerful extensions over the standard utility.")
             (sha256
              (base32
               "1rin1f5c7wm4n3piky6xilcrpf2s0n3dd5vqq8irrxkcic3i1w49"))
-            (patches (search-patches "binutils-loongson-workaround.patch"))))
+            (patches (local-patches "binutils-loongson-workaround.patch"))))
    (build-system gnu-build-system)
 
    ;; TODO: Add dependency on zlib + those for Gold.
@@ -722,7 +722,7 @@ the store.")
                    "use_ldconfig=no"))
                 #t))
             (modules '((guix build utils)))
-            (patches (search-patches "glibc-ldd-x86_64.patch"
+            (patches (local-patches "glibc-ldd-x86_64.patch"
                                      "glibc-hidden-visibility-ldconfig.patch"
                                      "glibc-versioned-locpath.patch"
                                      "glibc-allow-kernel-2.6.32.patch"
@@ -938,7 +938,7 @@ the store.")
                     ("python" ,python-minimal)
 
                     ,@(if (target-powerpc?)
-                        `(("powerpc64le-patch" ,@(search-patches
+                        `(("powerpc64le-patch" ,@(local-patches
                                                    "glibc-ldd-powerpc.patch")))
                         '())
                     ,@(if (hurd-target?)
@@ -979,7 +979,7 @@ with the Linux kernel.")
               (sha256
                (base32
                 "1bxqpg91d02qnaz837a5kamm0f43pr1il4r9pknygywsar713i72"))
-              (patches (search-patches "glibc-ldd-x86_64.patch"
+              (patches (local-patches "glibc-ldd-x86_64.patch"
                                        "glibc-CVE-2019-19126.patch"
                                        "glibc-hidden-visibility-ldconfig.patch"
                                        "glibc-versioned-locpath.patch"
@@ -997,7 +997,7 @@ with the Linux kernel.")
               (sha256
                (base32
                 "0jzh58728flfh939a8k9pi1zdyalfzlxmwra7k0rzji5gvavivpk"))
-              (patches (search-patches "glibc-ldd-x86_64.patch"
+              (patches (local-patches "glibc-ldd-x86_64.patch"
                                        "glibc-CVE-2019-7309.patch"
                                        "glibc-CVE-2019-9169.patch"
                                        "glibc-2.29-git-updates.patch"
@@ -1017,7 +1017,7 @@ with the Linux kernel.")
               (sha256
                (base32
                 "10iha5ynvdj5m62vgpgqbq4cwvc2yhyl2w9yyyjgfxmdmx8h145i"))
-              (patches (search-patches "glibc-ldd-x86_64.patch"
+              (patches (local-patches "glibc-ldd-x86_64.patch"
                                        "glibc-2.28-git-fixes.patch"
                                        "glibc-hidden-visibility-ldconfig.patch"
                                        "glibc-versioned-locpath.patch"
@@ -1036,7 +1036,7 @@ with the Linux kernel.")
               (sha256
                (base32
                 "0wpwq7gsm7sd6ysidv0z575ckqdg13cr2njyfgrbgh4f65adwwji"))
-              (patches (search-patches "glibc-ldd-x86_64.patch"
+              (patches (local-patches "glibc-ldd-x86_64.patch"
                                        "glibc-2.27-git-fixes.patch"
                                        "glibc-hidden-visibility-ldconfig.patch"
                                        "glibc-versioned-locpath.patch"
diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm
index 2b67cab609..d35179f5bc 100644
--- a/gnu/packages/bioinformatics.scm
+++ b/gnu/packages/bioinformatics.scm
@@ -5108,7 +5108,7 @@ form of assemblies or reads.")
        (sha256
         (base32
          "0hyg2smw1nz69mfvjpk45xyyychmda92c80a0cv7baji84ri4iyn"))
-       (patches (search-patches "metabat-fix-compilation.patch"))))
+       (patches (local-patches "metabat-fix-compilation.patch"))))
     (build-system scons-build-system)
     (arguments
      `(#:scons ,scons-python2
@@ -6232,7 +6232,7 @@ Roche 454, Ion Torrent and Pacific BioSciences SMRT.")
               (sha256
                (base32
                 "1n2s5wvvj2y0vfgjkg1q11xahpbagxz7h2vf5q7qyy25s12kbzbd"))
-              (patches (search-patches "mosaicatcher-unbundle-htslib.patch"))))
+              (patches (local-patches "mosaicatcher-unbundle-htslib.patch"))))
     (build-system cmake-build-system)
     (arguments
      `(#:tests? #false ; there are no tests
@@ -6454,7 +6454,7 @@ accessed/downloaded on demand across HTTP.")
              version "-src.zip"))
        (sha256
         (base32 "0as8gxm4pjyc8dxmm1sl873rrd7wn5qs0l29nqfnl31x8i467xaa"))
-       (patches (search-patches "plink-1.07-unclobber-i.patch"
+       (patches (local-patches "plink-1.07-unclobber-i.patch"
                                 "plink-endian-detection.patch"))))
     (build-system gnu-build-system)
     (arguments
@@ -7705,7 +7705,7 @@ includes software to
        (sha256
         (base32
          "0vhrpjfdf75ba04b24xknp41790cvcgwl0vgpy7qbzj5xh2521ss"))
-       (patches (search-patches "vsearch-unbundle-cityhash.patch"))
+       (patches (local-patches "vsearch-unbundle-cityhash.patch"))
        (snippet
         '(begin
            ;; Remove bundled cityhash sources.  The vsearch source is adjusted
diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm
index e7bd6cf002..237540d7e3 100644
--- a/gnu/packages/commencement.scm
+++ b/gnu/packages/commencement.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2014 Andreas Enge <[email-masked]>
 ;;; Copyright © 2012 Nikita Karetnikov <[email-masked]>
 ;;; Copyright © 2014, 2015, 2017 Mark H Weaver <[email-masked]>
@@ -2115,7 +2115,7 @@ ac_cv_c_float_format='IEEE (little-endian)'
                (method url-fetch)
                (uri (string-append "mirror://gnu/binutils/binutils-"
                                    version ".tar.bz2"))
-               (patches (search-patches "binutils-boot-2.20.1a.patch"))
+               (patches (local-patches "binutils-boot-2.20.1a.patch"))
                (sha256
                 (base32
                  "0r7dr0brfpchh5ic0z9r4yxqn4ybzmlh25sbp30cacqk8nb7rlvi")))))
@@ -2191,7 +2191,7 @@ ac_cv_c_float_format='IEEE (little-endian)'
                (uri (string-append "mirror://gnu/glibc/glibc-"
                                    version
                                    ".tar.gz"))
-               (patches (search-patches "glibc-boot-2.16.0.patch"
+               (patches (local-patches "glibc-boot-2.16.0.patch"
                                         "glibc-bootstrap-system-2.16.0.patch"))
                (sha256
                 (base32
@@ -3317,7 +3317,7 @@ memoized as a function of '%current-system'."
        ("perl" ,perl-boot0)
        ("python" ,python-boot0)
        ,@(if (target-powerpc?)
-           `(("powerpc64le-patch" ,@(search-patches
+           `(("powerpc64le-patch" ,@(local-patches
                                       "glibc-ldd-powerpc.patch")))
            '())))
     (inputs
@@ -3471,7 +3471,7 @@ exec ~a/bin/~a-~a -B~a/lib -Wl,-dynamic-linker -Wl,~a/~a \"$@\"~%"
    ;; This time we need 'msgfmt' to install all the libc.mo files.
    (native-inputs `(,@(package-native-inputs glibc-final-with-bootstrap-bash)
                      ,@(if (target-powerpc?)
-                         `(("powerpc64le-patch" ,@(search-patches
+                         `(("powerpc64le-patch" ,@(local-patches
                                                     "glibc-ldd-powerpc.patch")))
                          '())
                     ("gettext" ,gettext-boot0)))
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index 493ff2659f..1576b90503 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -155,7 +155,7 @@ where the OS part is overloaded to denote a specific ABI---into GCC
                  (sha256
                   (base32
                    "10k2k71kxgay283ylbbhhs51cl55zn2q38vj5pk4k950qdnirrlj"))
-                 (patches (search-patches "gcc-4-compile-with-gcc-5.patch"
+                 (patches (local-patches "gcc-4-compile-with-gcc-5.patch"
                                           "gcc-fix-texi2pod.patch"))))
        (build-system gnu-build-system)
 
@@ -380,7 +380,7 @@ Go.  It also includes runtime support libraries for these languages.")
               (sha256
                (base32
                 "08yggr18v373a1ihj0rg2vd6psnic42b518xcgp3r9k81xz1xyr2"))
-              (patches (search-patches "gcc-arm-link-spec-fix.patch"
+              (patches (local-patches "gcc-arm-link-spec-fix.patch"
                                        "gcc-4.8-libsanitizer-fix.patch"
                                        "gcc-asan-missing-include.patch"
                                        "gcc-fix-texi2pod.patch"))
@@ -413,7 +413,7 @@ Go.  It also includes runtime support libraries for these languages.")
               (sha256
                (base32
                 "14l06m7nvcvb0igkbip58x59w3nq6315k6jcz3wr9ch1rn9d44bc"))
-              (patches (search-patches "gcc-4.9-libsanitizer-fix.patch"
+              (patches (local-patches "gcc-4.9-libsanitizer-fix.patch"
                                        "gcc-4.9-libsanitizer-ustat.patch"
                                        "gcc-4.9-libsanitizer-mode-size.patch"
                                        "gcc-arm-bug-71399.patch"
@@ -475,7 +475,7 @@ Go.  It also includes runtime support libraries for these languages.")
               (sha256
                (base32
                 "11zd1hgzkli3b2v70qsm2hyqppngd4616qc96lmm9zl2kl9yl32k"))
-              (patches (search-patches "gcc-arm-bug-71399.patch"
+              (patches (local-patches "gcc-arm-bug-71399.patch"
                                        "gcc-libsanitizer-ustat.patch"
                                        "gcc-strmov-store-file-names.patch"
                                        "gcc-5.0-libvtv-runpath.patch"
@@ -514,7 +514,7 @@ Go.  It also includes runtime support libraries for these languages.")
               (sha256
                (base32
                 "0i89fksfp6wr1xg9l8296aslcymv2idn60ip31wr9s4pwin7kwby"))
-              (patches (search-patches "gcc-strmov-store-file-names.patch"
+              (patches (local-patches "gcc-strmov-store-file-names.patch"
                                        "gcc-6-libsanitizer-mode-size.patch"
                                        "gcc-6-source-date-epoch-1.patch"
                                        "gcc-6-source-date-epoch-2.patch"
@@ -544,7 +544,7 @@ Go.  It also includes runtime support libraries for these languages.")
               (sha256
                (base32
                 "0qg6kqc5l72hpnj4vr6l0p69qav0rh4anlkk3y55540zy3klc6dq"))
-              (patches (search-patches "gcc-strmov-store-file-names.patch"
+              (patches (local-patches "gcc-strmov-store-file-names.patch"
                                        "gcc-7-libsanitizer-mode-size.patch"
                                        "gcc-5.0-libvtv-runpath.patch"))))
     (description
@@ -563,7 +563,7 @@ It also includes runtime support libraries for these languages.")))
               (sha256
                (base32
                 "0l7d4m9jx124xsk6xardchgy2k5j5l2b15q322k31f0va4d8826k"))
-              (patches (search-patches "gcc-8-strmov-store-file-names.patch"
+              (patches (local-patches "gcc-8-strmov-store-file-names.patch"
                                        "gcc-5.0-libvtv-runpath.patch"
                                        "gcc-8-sort-libtool-find-output.patch"))))))
 
@@ -578,7 +578,7 @@ It also includes runtime support libraries for these languages.")))
             (sha256
              (base32
               "13l3p6g2krilaawbapmn9zmmrh3zdwc36mfr3msxfy038hps6pf9"))
-            (patches (search-patches "gcc-9-strmov-store-file-names.patch"
+            (patches (local-patches "gcc-9-strmov-store-file-names.patch"
                                      "gcc-9-asan-fix-limits-include.patch"
                                      "gcc-5.0-libvtv-runpath.patch"))))))
 
@@ -593,7 +593,7 @@ It also includes runtime support libraries for these languages.")))
             (sha256
              (base32
               "0i6378ig6h397zkhd7m4ccwjx5alvzrf2hm27p1pzwjhlv0h9x34"))
-            (patches (search-patches "gcc-9-strmov-store-file-names.patch"
+            (patches (local-patches "gcc-9-strmov-store-file-names.patch"
                                      "gcc-5.0-libvtv-runpath.patch"))))))
 
 (define-public gcc-11
@@ -607,7 +607,7 @@ It also includes runtime support libraries for these languages.")))
             (sha256
              (base32
               "12zs6vd2rapp42x154m479hg3h3lsafn3xhg06hp5hsldd9xr3nh"))
-            (patches (search-patches "gcc-9-strmov-store-file-names.patch"
+            (patches (local-patches "gcc-9-strmov-store-file-names.patch"
                                      "gcc-5.0-libvtv-runpath.patch"))))))
 
 ;; Note: When changing the default gcc version, update
@@ -1129,7 +1129,7 @@ dependence analysis and bounds on piecewise step-polynomials.")
              (sha256
               (base32
                "13d9cqa5rzhbjq0xf0b2dyxag7pqa72xj9dhsa03m8ccr1a4npq9"))
-             (patches (search-patches "isl-0.11.1-aarch64-support.patch"))))))
+             (patches (local-patches "isl-0.11.1-aarch64-support.patch"))))))
 
 (define-public cloog
   (package
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index 3bb57ee2bd..413c3cb01e 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -116,7 +116,7 @@
       (sha256
        (base32
         "0hds28cg226m8j8sr394nm9yc4gxhvlv109w0avsf2mxrlrz0hsd"))
-      (patches (search-patches "python-2.7-search-paths.patch"
+      (patches (local-patches "python-2.7-search-paths.patch"
                                "python-2-deterministic-build-info.patch"
                                "python-2.7-site-prefixes.patch"
                                "python-2.7-source-date-epoch.patch"
@@ -370,7 +370,7 @@ data types.")
               (method url-fetch)
               (uri (string-append "https://www.python.org/ftp/python/"
                                   version "/Python-" version ".tar.xz"))
-              (patches (search-patches
+              (patches (local-patches
                         "python-CVE-2020-26116.patch"
                         "python-3.8-CVE-2021-3177.patch"
                         "python-3-fix-tests.patch"
@@ -531,7 +531,7 @@ data types.")
               (method url-fetch)
               (uri (string-append "https://www.python.org/ftp/python/"
                                   version "/Python-" version ".tar.xz"))
-              (patches (search-patches
+              (patches (local-patches
                         "python-3.9-fix-tests.patch"
                         "python-3-deterministic-build-info.patch"
                         "python-3-search-paths.patch"))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index f3d278b3e6..830fea6c1d 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -30,12 +30,15 @@
   #:use-module (guix diagnostics)
   #:use-module (guix i18n)
   #:use-module (rnrs bytevectors)
+  #:autoload   (gcrypt hash) (file-sha256 open-sha256-port)
+  #:autoload   (guix serialization) (write-file)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:export (gexp
@@ -59,6 +62,7 @@
             local-file-name
             local-file-recursive?
             local-file-select?
+            local-file-cache-authoritative?
 
             plain-file
             plain-file?
@@ -421,27 +425,30 @@ Here TARGET is bound to the cross-compilation triplet or #f."
 ;; absolute file name.  We keep it in a promise to compute it lazily and avoid
 ;; repeated 'stat' calls.
 (define-record-type <local-file>
-  (%%local-file file absolute name recursive? select?)
+  (%%local-file file absolute name recursive? select?
+                store-file)
   local-file?
   (file       local-file-file)                    ;string
   (absolute   %local-file-absolute-file-name)     ;promise string
   (name       local-file-name)                    ;string
   (recursive? local-file-recursive?)              ;Boolean
-  (select?    local-file-select?))                ;string stat -> Boolean
+  (select?    local-file-select?)                 ;string stat -> Boolean
+  (store-file local-file-store-file))             ;string | #f
 
 (define (true file stat) #t)
 
 (define* (%local-file file promise #:optional (name (basename file))
                       #:key
                       (literal? #t) location
-                      recursive? (select? true))
+                      recursive? (select? true) store-file)
   ;; This intermediate procedure is part of our ABI, but the underlying
   ;; %%LOCAL-FILE is not.
   (when (and (not literal?) (not (string-prefix? "/" file)))
     (warning (and=> location source-properties->location)
              (G_ "resolving '~a' relative to current directory~%")
              file))
-  (%%local-file file promise name recursive? select?))
+  (%%local-file file promise name recursive? select?
+                store-file))
 
 (define (absolute-file-name file directory)
   "Return the canonical absolute file name for FILE, which lives in the
@@ -451,7 +458,7 @@ vicinity of DIRECTORY."
          ((not directory) file)
          ((string-prefix? "/" directory)
           (string-append directory "/" file))
-         (else file))))
+         (else (string-append directory "/" file)))))
 
 (define-syntax-rule (assume-valid-file-name file)
   "This is a syntactic keyword to tell 'local-file' that it can assume that
@@ -477,13 +484,43 @@ where FILE is the entry's absolute file name and STAT is the result of
 This is the declarative counterpart of the 'interned-file' monadic procedure.
 It is implemented as a macro to capture the current source directory where it
 appears."
+    (define (store-file-name file recursive?)
+      (pk 'f-o-p file recursive?
+          (fixed-output-path (basename file)
+                             (if recursive?
+                                 (let ((port get-hash (open-sha256-port)))
+                                   (write-file file port)
+                                   (force-output port)
+                                   (get-hash))
+                                 (file-sha256 file))
+                          #:hash-algo 'sha256
+                          #:recursive? recursive?)))
+
     (syntax-case s (assume-valid-file-name)
       ((_ file rest ...)
        (string? (syntax->datum #'file))
        ;; FILE is a literal, so resolve it relative to the source directory.
-       #'(%local-file file
-                      (delay (absolute-file-name file (current-source-directory)))
-                      rest ...))
+       (let* ((directory (and=> (syntax-source s)
+                                (lambda (properties)
+                                  (and=> (assq-ref properties 'filename) dirname))))
+              (absolute  (and directory
+                              (absolute-file-name (syntax->datum #'file)
+                                                  directory)))
+              (recursive? (equal? '(#:recursive? #t)
+                                  (syntax->datum #'(rest ...))))
+              (store-file (and absolute
+                               (or recursive?
+                                   (null? (syntax->datum #'(rest ...))))
+                               (catch 'system-error
+                                 (lambda ()
+                                   (store-file-name absolute recursive?))
+                                 (const #f)))))
+         #`(%local-file file
+                        (delay (absolute-file-name file (current-source-directory)))
+                        #,@(if store-file
+                               #`(#:store-file #,store-file)
+                               #'())
+                        rest ...)))
       ((_ (assume-valid-file-name file) rest ...)
        ;; FILE is not a literal, so resolve it relative to the current
        ;; directory.  Since the user declared FILE is valid, do not pass
@@ -514,16 +551,34 @@ appears."
 'system-error' exception is raised if FILE could not be found."
   (force (%local-file-absolute-file-name file)))
 
+(define valid-path?*
+  (store-lift valid-path?))
+(define add-temp-root*
+  (store-lift add-temp-root))
+
+(define local-file-cache-authoritative?
+  (make-parameter (and (not (getenv "GUIX_DISABLE_LOCAL_FILE_CACHE"))
+                       #;(not (getenv "GUIX_UNINSTALLED")))))
+
 (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 recursive? select?)
+    (($ <local-file> file absolute name recursive? select?
+                     store-file)
      ;; 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?))))
+     (mlet %store-monad ((valid? (if (and store-file
+                                          (local-file-cache-authoritative?))
+                                     (mbegin %store-monad
+                                       ;; (add-temp-root* store-file)
+                                       (valid-path?* store-file))
+                                     (return #f))))
+       (if valid?
+           (return store-file)
+           (interned-file (force absolute) name
+                          #:recursive? recursive? #:select? select?))))))
 
 (define-record-type <plain-file>
   (%plain-file name content references)