From: "Ludovic Courtès" <ludo@gnu.org>
To: Maxime Devos <maximedevos@telenet.be>
Cc: 50384@debbugs.gnu.org
Subject: [bug#50384] [PATCH v4] Optimise search-patch (reducing I/O)
Date: Tue, 21 Sep 2021 18:55:27 +0200 [thread overview]
Message-ID: <87r1dhj2bk.fsf_-_@gnu.org> (raw)
In-Reply-To: <87ee9xerac.fsf_-_@gnu.org> ("Ludovic Courtès"'s message of "Thu, 09 Sep 2021 16:51:07 +0200")
[-- Attachment #1: Type: text/plain, Size: 3722 bytes --]
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 <ludo@gnu.org> 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’.
[-- Attachment #2: Type: text/x-patch, Size: 27716 bytes --]
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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
@@ -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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org>
@@ -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)
next prev parent reply other threads:[~2021-09-21 16:56 UTC|newest]
Thread overview: 16+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-09-04 21:17 [bug#50384] [PATCH] Optimise search-patch (reducing I/O) Maxime Devos
2021-09-04 21:47 ` Ludovic Courtès
2021-09-04 22:04 ` Ludovic Courtès
2021-09-05 19:48 ` [bug#50384] [PATCH v2] " Maxime Devos
2021-09-05 22:40 ` Maxime Devos
2021-09-06 8:39 ` zimoun
2021-09-06 10:06 ` Maxime Devos
2021-09-09 14:51 ` [bug#50384] [PATCH] " Ludovic Courtès
2021-09-21 16:55 ` Ludovic Courtès [this message]
2021-09-23 17:26 ` [bug#50384] [PATCH v4] " Maxime Devos
2021-09-27 16:17 ` Ludovic Courtès
2021-10-04 16:46 ` [bug#50384] [PATCH] " zimoun
2021-10-08 7:41 ` Ludovic Courtès
2021-10-11 8:09 ` [bug#39258] bug#50384: " zimoun
2021-09-09 20:25 ` [bug#50384] [PATCH v3] " Maxime Devos
2021-09-10 9:54 ` bug#50384: " Maxime Devos
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87r1dhj2bk.fsf_-_@gnu.org \
--to=ludo@gnu.org \
--cc=50384@debbugs.gnu.org \
--cc=maximedevos@telenet.be \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.