grafts: Memoize intermediate results in 'cumulative-grafts'.

The time for:

  guix build inkscape -n --no-substitutes

goes down by 30% (in the presence of 3 replacements among all the
packages.)

* guix/grafts.scm (cumulative-grafts): Turn into a monadic procedure in
%STATE-MONAD.  Use the current state as a derivation-to-graft cache.
(graft-derivation): Call 'cumulative-grafts' within 'run-with-state'.

1 files changed, 35 insertions, 19 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index eca0a9fcad..af469575db 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -217,7 +217,10 @@ available."
   "Augment GRAFTS with additional grafts resulting from the application of
 GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure
 that returns the list of references of the store item it is given.  Return the
-resulting list of grafts."
+resulting list of grafts.
+
+This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
+derivations to the corresponding set of grafts."
   (define (dependency-grafts item)
     (let-values (((drv output) (item->deriver store item)))
       (if drv
@@ -225,23 +228,34 @@ resulting list of grafts."
                              #:outputs (list output)
                              #:guile guile
                              #:system system)
-          grafts)))
+          (state-return grafts))))
+
+  (define (return/cache cache value)
+    (mbegin %store-monad
+      (set-current-state (vhash-consq drv value cache))
+      (return value)))
 
-  ;; TODO: Memoize.
-  (match (non-self-references references drv outputs)
-    (()                                           ;no dependencies
-     grafts)
-    (deps                                         ;one or more dependencies
-     (let* ((grafts  (delete-duplicates (append-map dependency-grafts deps)
-                                        eq?))
-            (origins (map graft-origin-file-name grafts)))
-       (if (find (cut member <> deps) origins)
-           (let ((new (graft-derivation/shallow store drv grafts
-                                                #:guile guile
-                                                #:system system)))
-             (cons (graft (origin drv) (replacement new))
-                   grafts))
-           grafts)))))
+  (mlet %state-monad ((cache (current-state)))
+    (match (vhash-assq drv cache)
+      ((_ . grafts)                               ;hit
+       (return grafts))
+      (#f                                         ;miss
+       (match (non-self-references references drv outputs)
+         (()                                      ;no dependencies
+          (return/cache cache grafts))
+         (deps                                    ;one or more dependencies
+          (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))
+                              (cache  (current-state)))
+            (let* ((grafts  (delete-duplicates (concatenate grafts) equal?))
+                   (origins (map graft-origin-file-name grafts)))
+              (if (find (cut member <> deps) origins)
+                  (let* ((new    (graft-derivation/shallow store drv grafts
+                                                           #:guile guile
+                                                           #:system system))
+                         (grafts (cons (graft (origin drv) (replacement new))
+                                       grafts)))
+                    (return/cache cache grafts))
+                  (return/cache cache grafts))))))))))
 
 (define* (graft-derivation store drv grafts
                            #:key (guile (%guile-for-build))
@@ -256,8 +270,10 @@ DRV itself to refer to those grafted dependencies."
   (define references
     (references-oracle store drv))
 
-  (match (cumulative-grafts store drv grafts references
-                            #:guile guile #:system system)
+  (match (run-with-state
+             (cumulative-grafts store drv grafts references
+                                #:guile guile #:system system)
+           vlist-null)                            ;the initial cache
     ((first . rest)
      ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
      ;; applicable to DRV and nothing needs to be done.