diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2022-05-13 09:01:16 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2022-05-18 23:27:03 +0200 |
| commit | 001f4afd0771bafe1f17e709070b8ef56b5bdfea (patch) | |
| tree | 41a17201a50681c538ea49fa10ba677f27c1b0af | |
| parent | ba6ba1a5af4aae36f9abc22ca5e6128f49576c9d (diff) | |
| download | guix-001f4afd0771bafe1f17e709070b8ef56b5bdfea.tar.gz guix-001f4afd0771bafe1f17e709070b8ef56b5bdfea.zip | |
packages: Use separate package/graft cache.
* guix/packages.scm (%package-graft-cache): New variable.
(input-graft): Add (=> %package-graft-cache).
| -rw-r--r-- | guix/packages.scm | 12 |
1 files changed, 8 insertions, 4 deletions
diff --git a/guix/packages.scm b/guix/packages.scm index a79b36d03d..7ee65e9b6b 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1618,6 +1618,11 @@ and return it." (&package-error (package package)))))))))))) +(define %package-graft-cache + ;; Cache mapping <package> records to <graft> records, for packages that + ;; have a replacement. + (allocate-store-connection-cache 'package-graft-cache)) + (define (input-graft system) "Return a monadic procedure that, given a package with a graft, returns a graft, and #f otherwise." @@ -1626,9 +1631,8 @@ graft, and #f otherwise." (((? package? package) output) (let ((replacement (package-replacement package))) (if replacement - ;; XXX: We should use a separate cache instead of abusing the - ;; object cache. - (mcached (mlet %store-monad ((orig (package->derivation package system + (mcached eq? (=> %package-graft-cache) + (mlet %store-monad ((orig (package->derivation package system #:graft? #f)) (new (package->derivation replacement system #:graft? #t))) @@ -1637,7 +1641,7 @@ graft, and #f otherwise." (origin-output output) (replacement new) (replacement-output output)))) - package 'graft output system) + package output system) (return #f)))) (_ (return #f))))) |