grafts: Improve performance for derivations with many inputs.

Partly fixes <https://bugs.gnu.org/41702>.
Reported by Lars-Dominik Braun <ldb@leibniz-psychology.org>.

Previously we'd potentially traverse the same sub-graph of DEPS several
times.

With this patch, command:

  guix environment --ad-hoc r-learnr --search-paths

goes from 11.3s to 4.6s.

* guix/grafts.scm (reference-origin): Rename to...
(reference-origins): ... this.  Change 'item' parameter to 'items'.
[lookup-derivers]: New procedure.
(cumulative-grafts)[dependency-grafts]: Change 'item' to 'items' and use
'reference-origins'.
Remove 'mapm' around 'dependency-grafts' call.

1 files changed, 52 insertions, 33 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index 69d6fe4469..910dcadc8a 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -20,10 +20,12 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix records)
+  #:use-module (guix combinators)
   #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (guix sets)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -183,32 +185,47 @@ references."
            (set-current-state (vhash-cons key result cache))
            (return result)))))))
 
-(define (reference-origin drv item)
-  "Return the derivation/output pair among the inputs of DRV, recursively,
-that produces ITEM.  Return #f if ITEM is not produced by a derivation (i.e.,
-it's a content-addressed \"source\"), or if it's not produced by a dependency
-of DRV."
+(define (reference-origins drv items)
+  "Return the derivation/output pairs among the inputs of DRV, recursively,
+that produce ITEMS.  Elements of ITEMS not produced by a derivation (i.e.,
+it's a content-addressed \"source\"), or not produced by a dependency of DRV,
+have no corresponding element in the resulting list."
+  (define (lookup-derivers drv result items)
+    ;; Return RESULT augmented by all the drv/output pairs producing one of
+    ;; ITEMS, and ITEMS stripped of matching items.
+    (fold2 (match-lambda*
+             (((output . file) result items)
+              (if (member file items)
+                  (values (alist-cons drv output result)
+                          (delete file items))
+                  (values result items))))
+           result items
+           (derivation->output-paths drv)))
+
   ;; Perform a breadth-first traversal of the dependency graph of DRV in
-  ;; search of the derivation that produces ITEM.
+  ;; search of the derivations that produce ITEMS.
   (let loop ((drv (list drv))
+             (items items)
+             (result '())
              (visited (setq)))
     (match drv
       (()
-       #f)
+       result)
       ((drv . rest)
-       (if (set-contains? visited drv)
-           (loop rest visited)
-           (let ((inputs (derivation-inputs drv)))
-             (or (any (lambda (input)
-                        (let ((drv (derivation-input-derivation input)))
-                          (any (match-lambda
-                                 ((output . file)
-                                  (and (string=? file item)
-                                       (cons drv output))))
-                               (derivation->output-paths drv))))
-                      inputs)
-                 (loop (append rest (map derivation-input-derivation inputs))
-                       (set-insert drv visited)))))))))
+       (cond ((null? items)
+              result)
+             ((set-contains? visited drv)
+              (loop rest items result visited))
+             (else
+              (let*-values (((inputs)
+                             (map derivation-input-derivation
+                                  (derivation-inputs drv)))
+                            ((result items)
+                             (fold2 lookup-derivers
+                                    result items inputs)))
+                (loop (append rest inputs)
+                      items result
+                      (set-insert drv visited)))))))))
 
 (define* (cumulative-grafts store drv grafts
                             #:key
@@ -233,25 +250,27 @@ derivations to the corresponding set of grafts."
       (_
        #f)))
 
-  (define (dependency-grafts item)
-    (match (reference-origin drv item)
-      ((drv . output)
-       ;; If GRAFTS already contains a graft from DRV, do not override it.
-       (if (find (cut graft-origin? drv <>) grafts)
-           (state-return grafts)
-           (cumulative-grafts store drv grafts
-                              #:outputs (list output)
-                              #:guile guile
-                              #:system system)))
-      (#f
-       (state-return grafts))))
+  (define (dependency-grafts items)
+    (mapm %store-monad
+          (lambda (drv+output)
+            (match drv+output
+              ((drv . output)
+               ;; If GRAFTS already contains a graft from DRV, do not
+               ;; override it.
+               (if (find (cut graft-origin? drv <>) grafts)
+                   (state-return grafts)
+                   (cumulative-grafts store drv grafts
+                                      #:outputs (list output)
+                                      #:guile guile
+                                      #:system system)))))
+          (reference-origins drv items)))
 
   (with-cache (cons (derivation-file-name drv) outputs)
     (match (non-self-references store drv outputs)
       (()                                         ;no dependencies
        (return grafts))
       (deps                                       ;one or more dependencies
-       (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
+       (mlet %state-monad ((grafts (dependency-grafts deps)))
          (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
            (match (filter (lambda (graft)
                             (member (graft-origin-file-name graft) deps))