From 001f4afd0771bafe1f17e709070b8ef56b5bdfea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 May 2022 09:01:16 +0200 Subject: packages: Use separate package/graft cache. * guix/packages.scm (%package-graft-cache): New variable. (input-graft): Add (=> %package-graft-cache). --- guix/packages.scm | 12 ++++++++---- 1 file 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 records to 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))))) -- cgit v1.2.3