Browse Source

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.
wip-hurd-vm
Ludovic Courtès 2 years ago
parent
commit
58bb833365
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 85
      guix/grafts.scm

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

Loading…
Cancel
Save