06/07: grafts: Memoize intermediate results in 'cumulative-grafts'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d4da602e4c28d704ee04ec57887fa14b134c7ebb
Author: Ludovic Courtès <address@hidden>
Date:   Fri Mar 4 23:10:28 2016 +0100

    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'.
---
 guix/grafts.scm |   54 +++++++++++++++++++++++++++++++++++-------------------
 1 files changed, 35 insertions(+), 19 deletions(-)

diff --git a/guix/grafts.scm b/guix/grafts.scm
index eca0a9f..af46957 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.