03/04: packages: Use separate package/graft cache.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 001f4afd0771bafe1f17e709070b8ef56b5bdfea
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri May 13 09:01:16 2022 +0200

    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 <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)))))