03/03: packages: Cache the result of 'input-grafts'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit ced71ac7a78f12d39a41f7102019bdb1aec93dee
Author: Ludovic Courtès <address@hidden>
Date:   Mon Mar 7 23:57:33 2016 +0100

    packages: Cache the result of 'input-grafts'.
    
    This reduces the wall-clock time of
    
      guix environment gnutls --pure -E true
    
    by ~35%.
    
    * guix/packages.scm (%graft-cache): New variable.
    (input-graft): Use 'cached' to cache to %GRAFT-CACHE.
---
 guix/packages.scm |   18 ++++++++++++------
 1 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 92222c0..d62d1f3 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -843,6 +843,11 @@ and return it."
                                (&package-error
                                 (package package)))))))))))
 
+(define %graft-cache
+  ;; 'eq?' cache mapping package objects to a graft corresponding to their
+  ;; replacement package.
+  (make-weak-key-hash-table 200))
+
 (define (input-graft store system)
   "Return a procedure that, given a package with a graft, returns a graft, and
 #f otherwise."
@@ -850,12 +855,13 @@ and return it."
     ((? package? package)
      (let ((replacement (package-replacement package)))
        (and replacement
-            (let ((orig (package-derivation store package system
-                                            #:graft? #f))
-                  (new  (package-derivation store replacement system)))
-              (graft
-                (origin orig)
-                (replacement new))))))
+            (cached (=> %graft-cache) package system
+                    (let ((orig (package-derivation store package system
+                                                    #:graft? #f))
+                          (new  (package-derivation store replacement system)))
+                      (graft
+                        (origin orig)
+                        (replacement new)))))))
     (x
      #f)))