bug#41702: `guix environment` performance issues

[Ludovic Courtès]

Hi,

Lars-Dominik Braun <ldb@leibniz-psychology.org> skribis:

> Total time: 24.672604202 seconds (19.431122691 seconds in GC)
> ./pre-inst-env guix environment --ad-hoc r-learnr -- true  25,18s user 0,24s 
> system 308% cpu 8,248 total
>
> More specifically in an anonymous function and reap-pipes, which is a gc hook,
> I believe:
>
> %     cumulative   self
> time   seconds    seconds   calls   procedure
>  33.41     14.49      8.24                            anon #xbb8480
>  27.95      6.90      6.90                            
> ice-9/popen.scm:145:0:reap-pipes
>   4.37      1.08      1.08                            anon #xbbdcd8
>   3.28      0.86      0.81                            
> ice-9/vlist.scm:539:0:vhash-assq
>   2.40      2.37      0.59                            guix/grafts.scm:202:22

Guile master has a fix for statprof that yields more useful info:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,use(guix scripts environment)
scheme@(guile-user)> ,pr (guix-environment "--ad-hoc" "r-learnr" "--" "true")
%     cumulative   self             
time   seconds     seconds  procedure
 29.84      9.87      6.16  append
 19.56      4.04      4.04  %after-gc-thunk
  6.85      1.87      1.42  ice-9/vlist.scm:539:0:vhash-assq
  5.44      1.17      1.12  write
  3.23      0.67      0.67  guix/derivations.scm:665:0:derivation->output-paths
  2.82      0.58      0.58  string=?
  2.42      2.37      0.50  guix/grafts.scm:202:22
  2.42      0.50      0.50  list?
  2.22      0.46      0.46  hashq
  2.02      0.42      0.42  display
  1.61     15.82      0.33  guix/grafts.scm:186:0:reference-origin
  1.61      0.87      0.33  guix/grafts.scm:204:31
  1.21      0.33      0.25  guix/derivations.scm:667:7
  1.21      0.29      0.25  srfi/srfi-1.scm:817:0:any
  1.01   1232.14      0.21  srfi/srfi-1.scm:584:5:map1
  0.81      0.83      0.17  guix/derivations.scm:697:0:derivation/masked-inputs
  0.81      0.75      0.17  srfi/srfi-1.scm:580:2:map
  0.81      0.17      0.17  
guix/derivations.scm:158:0:%derivation-input-derivation-procedure
  0.60      0.17      0.12  reverse
  0.60      0.12      0.12  hashq-ref
  0.60      0.12      0.12  get-bytevector-n
  0.60      0.12      0.12  procedure?
  0.40      0.67      0.08  guix/packages.scm:1232:0:fold-bag-dependencies
  0.40      0.12      0.08  string->utf8
  0.40      0.12      0.08  ice-9/vlist.scm:534:0:vhash-assoc
  0.40      0.12      0.08  ice-9/vlist.scm:449:0:vhash-cons
  0.40      0.12      0.08  delete-duplicates
  0.40      0.08      0.08  ice-9/boot-9.scm:1389:0:->bool
  0.40      0.08      0.08  ice-9/boot-9.scm:2201:0:%load-announce
  0.40      0.08      0.08  hash
  0.40      0.08      0.08  guix/derivations.scm:665:0:derivation->output-paths
  0.20     20.73      0.04  guix/gexp.scm:1061:2
--8<---------------cut here---------------end--------------->8---

Notice that the same command with ‘--no-grafts’ takes 2s instead of 11s.

The patch below arranges so that ‘cumulative-grafts’ processes
dependencies in a batch, such that the derivation’s dependency graph is
traversed once for all, which makes a difference for derivations with
lots of inputs.

Here’s the before/after comparison:

--8<---------------cut here---------------start------------->8---
$ time guix environment --ad-hoc r-learnr --search-paths
export 
PATH="/gnu/store/n4wxbmqpafjfyawrla8xymzzdm5hxwph-profile/bin${PATH:+:}$PATH"

real    0m11.328s
user    0m20.155s
sys     0m0.172s
$ time ./pre-inst-env guix environment --ad-hoc r-learnr --search-paths
export 
PATH="/gnu/store/if6z77la3mx0qdzvcyl4qv9i5cyp48i0-profile/bin${PATH:+:}$PATH"

real    0m4.602s
user    0m6.189s
sys     0m0.136s
--8<---------------cut here---------------end--------------->8---

There’s still room for improvement, but it’s much better.

Ludo’.

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))