From c90cb5c9d84ded26ef44d1e6593508d5b9e4655e Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 4 Mar 2016 21:49:08 +0100
Subject: grafts: Use dependency information from substitutes when possible.

This avoids starting derivation builds just for the sake of knowing the
references of their outputs, thereby restoring the expected behavior of
--dry-run when substitutes are available.

* guix/grafts.scm (non-self-references): Remove 'store' parameter, and
add 'references'.  Use it.  Update caller.
(references-oracle): New variable.
(cumulative-grafts): Add 'references' parameter and use it.  Update
callers.
(graft-derivation): Remove 'build-derivations' call.  Add call to
'references-oracle'.
---
 guix/grafts.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 51 insertions(+), 12 deletions(-)

(limited to 'guix')

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 9bcc5e2ef8..eca0a9fcad 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -26,7 +26,9 @@ (define-module (guix grafts)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
   #:export (graft?
             graft
             graft-origin
@@ -162,36 +164,71 @@ (define (item->deriver store item)
                        (and (string=? item path) name)))
                     (derivation->output-paths drv)))))))
 
-(define (non-self-references store drv outputs)
+(define (non-self-references references drv outputs)
   "Return the list of references of the OUTPUTS of DRV, excluding self
-references."
-  (let ((refs (append-map (lambda (output)
-                            (references store
-                                        (derivation->output-path drv output)))
+references.  Call REFERENCES to get the list of references."
+  (let ((refs (append-map (compose references
+                                   (cut derivation->output-path drv <>))
                           outputs))
         (self (match (derivation->output-paths drv)
                 (((names . items) ...)
                  items))))
     (remove (cut member <> self) refs)))
 
+(define (references-oracle store drv)
+  "Return a one-argument procedure that, when passed the file name of DRV's
+outputs or their dependencies, returns the list of references of that item.
+Use either local info or substitute info; build DRV if no information is
+available."
+  (define (output-paths drv)
+    (match (derivation->output-paths drv)
+      (((names . items) ...)
+       items)))
+
+  (define (references* items)
+    (guard (c ((nix-protocol-error? c)
+               ;; As a last resort, build DRV and query the references of the
+               ;; build result.
+               (and (build-derivations store (list drv))
+                    (map (cut references store <>) items))))
+      (references/substitutes store items)))
+
+  (let loop ((items (output-paths drv))
+             (result vlist-null))
+    (match items
+      (()
+       (lambda (item)
+         (match (vhash-assoc item result)
+           ((_ . refs) refs)
+           (#f         #f))))
+      (_
+       (let* ((refs   (references* items))
+              (result (fold vhash-cons result items refs)))
+         (loop (remove (cut vhash-assoc <> result)
+                       (delete-duplicates (concatenate refs) string=?))
+               result))))))
+
 (define* (cumulative-grafts store drv grafts
+                            references
                             #:key
                             (outputs (derivation-output-names drv))
                             (guile (%guile-for-build))
                             (system (%current-system)))
   "Augment GRAFTS with additional grafts resulting from the application of
-GRAFTS to the dependencies of DRV.  Return the resulting list of grafts."
+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."
   (define (dependency-grafts item)
     (let-values (((drv output) (item->deriver store item)))
       (if drv
-          (cumulative-grafts store drv grafts
+          (cumulative-grafts store drv grafts references
                              #:outputs (list output)
                              #:guile guile
                              #:system system)
           grafts)))
 
   ;; TODO: Memoize.
-  (match (non-self-references store drv outputs)
+  (match (non-self-references references drv outputs)
     (()                                           ;no dependencies
      grafts)
     (deps                                         ;one or more dependencies
@@ -213,11 +250,13 @@ (define* (graft-derivation store drv grafts
 GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
 DRV itself to refer to those grafted dependencies."
 
-  ;; First, we need to build the ungrafted DRV so we can query its run-time
-  ;; dependencies in 'cumulative-grafts'.
-  (build-derivations store (list drv))
+  ;; First, pre-compute the dependency tree of the outputs of DRV.  Do this
+  ;; upfront to have as much parallelism as possible when querying substitute
+  ;; info or when building DRV.
+  (define references
+    (references-oracle store drv))
 
-  (match (cumulative-grafts store drv grafts
+  (match (cumulative-grafts store drv grafts references
                             #:guile guile #:system system)
     ((first . rest)
      ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
-- 
cgit v1.2.3