3 files changed, 52 insertions(+), 31 deletions(-)

M guix/derivations.scm
M guix/ui.scm
M tests/derivations.scm

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;


@@ 62,6 62,7 @@
             fixed-output-derivation?
             offloadable-derivation?
             substitutable-derivation?
+            substitution-oracle
             derivation-hash
 
             read-derivation


@@ 184,39 185,52 @@ download with a fixed hash (aka. `fetchurl')."
   ;; synonymous, see <http://bugs.gnu.org/18747>.
   offloadable-derivation?)
 
+(define (derivation-output-paths drv sub-drvs)
+  "Return the output paths of outputs SUB-DRVS of DRV."
+  (match drv
+    (($ <derivation> outputs)
+     (map (lambda (sub-drv)
+            (derivation-output-path (assoc-ref outputs sub-drv)))
+          sub-drvs))))
+
+(define* (substitution-oracle store drv)
+  "Return a one-argument procedure that, when passed a store file name,
+returns #t if it's substitutable and #f otherwise.  The returned procedure
+knows about all substitutes for all the derivations listed in DRV and their
+prerequisites.
+
+Creating a single oracle (thus making a single 'substitutable-paths' call) and
+reusing it is much more efficient than calling 'has-substitutes?' or similar
+repeatedly, because it avoids the costs associated with launching the
+substituter many times."
+  (let* ((paths (delete-duplicates
+                 (fold (lambda (drv result)
+                         (let ((self (match (derivation->output-paths drv)
+                                       (((names . paths) ...)
+                                        paths)))
+                               (deps (append-map derivation-input-output-paths
+                                                 (derivation-prerequisites
+                                                  drv))))
+                           (append self deps result)))
+                       '()
+                       drv)))
+         (subst (substitutable-paths store paths)))
+    (cut member <> subst)))
+
 (define* (derivation-prerequisites-to-build store drv
                                             #:key
                                             (outputs
                                              (derivation-output-names drv))
-                                            (use-substitutes? #t))
+                                            (substitutable?
+                                             (substitution-oracle store
+                                                                  (list drv))))
   "Return two values: the list of derivation-inputs required to build the
 OUTPUTS of DRV and not already available in STORE, recursively, and the list
-of required store paths that can be substituted.  When USE-SUBSTITUTES? is #f,
-that second value is the empty list."
-  (define (derivation-output-paths drv sub-drvs)
-    (match drv
-      (($ <derivation> outputs)
-       (map (lambda (sub-drv)
-              (derivation-output-path (assoc-ref outputs sub-drv)))
-            sub-drvs))))
-
+of required store paths that can be substituted.  SUBSTITUTABLE? must be a
+one-argument procedure similar to that returned by 'substitution-oracle'."
   (define built?
     (cut valid-path? store <>))
 
-  (define substitutable?
-    ;; Return true if the given path is substitutable.  Call
-    ;; `substitutable-paths' upfront, to benefit from parallelism in the
-    ;; substituter.
-    (if use-substitutes?
-        (let ((s (substitutable-paths store
-                                      (append
-                                       (derivation-output-paths drv outputs)
-                                       (append-map
-                                        derivation-input-output-paths
-                                        (derivation-prerequisites drv))))))
-          (cut member <> s))
-        (const #f)))
-
   (define input-built?
     (compose (cut any built? <>) derivation-input-output-paths))
 

@@ 1,5 1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>


@@ 299,21 299,27 @@ error."
 derivations listed in DRV.  Return #t if there's something to build, #f
 otherwise.  When USE-SUBSTITUTES?, check and report what is prerequisites are
 available for download."
+  (define substitutable?
+    ;; Call 'substitutation-oracle' upfront so we don't end up launching the
+    ;; substituter many times.  This makes a big difference, especially when
+    ;; DRV is a long list as is the case with 'guix environment'.
+    (if use-substitutes?
+        (substitution-oracle store drv)
+        (const #f)))
+
   (define (built-or-substitutable? drv)
     (let ((out (derivation->output-path drv)))
       ;; If DRV has zero outputs, OUT is #f.
       (or (not out)
           (or (valid-path? store out)
-              (and use-substitutes?
-                   (has-substitutes? store out))))))
+              (substitutable? out)))))
 
   (let*-values (((build download)
                  (fold2 (lambda (drv build download)
                           (let-values (((b d)
                                         (derivation-prerequisites-to-build
                                          store drv
-                                         #:use-substitutes?
-                                         use-substitutes?)))
+                                         #:substitutable? substitutable?)))
                             (values (append b build)
                                     (append d download))))
                         '() '()

@@ 589,7 589,8 @@
                     (derivation-prerequisites-to-build store drv))
                    ((build* download*)
                     (derivation-prerequisites-to-build store drv
-                                                       #:use-substitutes? #f)))
+                                                       #:substitutable?
+                                                       (const #f))))
         (and (null? build)
              (equal? download (list output))
              (null? download*)