03/03: derivations: Add 'substitution-oracle' and use it.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit e9651e39b315035eb9e87888155f8d6e33ef0567
Author: Ludovic Courtès <address@hidden>
Date:   Sat Jan 10 00:39:59 2015 +0100

    derivations: Add 'substitution-oracle' and use it.
    
    This makes 'guix environment PACKAGE' significantly faster when
    substitutes are enabled.  Before that, it would lead to many invocations
    of 'guix substitute-binary', one per 'derivation-prerequisites-to-build'
    call.  Now, all these are replaced by a single invocation.
    
    * guix/derivations.scm (derivation-output-paths, substitution-oracle):
      New procedures.
      (derivation-prerequisites-to-build): Replace #:use-substitutes? with
      #:substitutable?.  Remove the local 'derivation-output-paths' and
      'substitutable?'.
    * guix/ui.scm (show-what-to-build): Add 'substitutable?'.  Pass it to
      'derivation-prerequisites-to-build'.
      [built-or-substitutable?]: Use it instead of 'has-substitutes?'.
    * tests/derivations.scm ("derivation-prerequisites-to-build and
      substitutes"): Use #:substitutable? instead of #:use-substitutes?.
---
 guix/derivations.scm  |   64 +++++++++++++++++++++++++++++-------------------
 guix/ui.scm           |   16 ++++++++----
 tests/derivations.scm |    3 +-
 3 files changed, 52 insertions(+), 31 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 5e96d9f..ec438e8 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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))
 
diff --git a/guix/ui.scm b/guix/ui.scm
index c77e041..5bd4d1f 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013 Mark H Weaver <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2014 Alex Kost <address@hidden>
@@ -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))))
                         '() '()
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 25e6f75..8e592ab 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -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*)