summaryrefslogtreecommitdiff
path: root/guix/grafts.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-06-06 18:46:49 +0200
committerLudovic Courtès <ludo@gnu.org>2020-06-06 23:28:48 +0200
commit58bb833365db4e8934a386497d5b00a063cfd27d (patch)
treef355e18d609c09c2d21706ccf8aa20217ce666b8 /guix/grafts.scm
parent22fdca91a9edaca2ed0a714d2309470646c73c97 (diff)
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.
Diffstat (limited to 'guix/grafts.scm')
-rw-r--r--guix/grafts.scm85
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))