mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 23:46:13 -05:00
grafts: Simplify access to store item references.
This is a followup to 710854304b
.
This also slightly reduces the number of 'query-references' RPCs, for
instance from 176 to 166 from "guix build emacs -d".
* guix/grafts.scm (references-oracle): Remove.
(non-self-references): Remove 'references' parameter and add 'store'.
Add 'references*' procedure and use it instead of 'references'. Adjust
caller accordingly.
(cumulative-grafts): Remove 'references' parameter and adjust caller
accordingly.
This commit is contained in:
parent
65bdb2d9dd
commit
4b75a70600
1 changed files with 15 additions and 45 deletions
|
@ -152,43 +152,23 @@ (define properties
|
|||
|
||||
#:properties properties)))))
|
||||
|
||||
(define (non-self-references references drv outputs)
|
||||
(define (non-self-references store drv outputs)
|
||||
"Return the list of references of the OUTPUTS of DRV, excluding self
|
||||
references. Call REFERENCES to get the list of references."
|
||||
(let ((refs (append-map (compose references
|
||||
(cut derivation->output-path drv <>))
|
||||
outputs))
|
||||
(self (match (derivation->output-paths drv)
|
||||
(((names . items) ...)
|
||||
items))))
|
||||
(remove (cut member <> self) refs)))
|
||||
|
||||
(define (references-oracle store input)
|
||||
"Return a one-argument procedure that, when passed the output file names of
|
||||
INPUT, a derivation input, or their dependencies, returns the list of
|
||||
references of that item. Build INPUT if it's not available."
|
||||
references."
|
||||
(define (references* items)
|
||||
;; Return the references of ITEMS.
|
||||
(guard (c ((store-protocol-error? c)
|
||||
;; ITEMS are not in store so build INPUT first.
|
||||
(and (build-derivations store (list input))
|
||||
(map (cut references/cached store <>) items))))
|
||||
(map (cut references/cached store <>) items)))
|
||||
(and (build-derivations store (list drv))
|
||||
(append-map (cut references/cached store <>) items))))
|
||||
(append-map (cut references/cached store <>) items)))
|
||||
|
||||
(let loop ((items (derivation-input-output-paths input))
|
||||
(result vlist-null))
|
||||
(match items
|
||||
(()
|
||||
(lambda (item)
|
||||
(match (vhash-assoc item result)
|
||||
((_ . refs) refs)
|
||||
(#f #f))))
|
||||
(_
|
||||
(let* ((refs (references* items))
|
||||
(result (fold vhash-cons result items refs)))
|
||||
(loop (remove (cut vhash-assoc <> result)
|
||||
(delete-duplicates (concatenate refs) string=?))
|
||||
result))))))
|
||||
(let ((refs (references* (map (cut derivation->output-path drv <>)
|
||||
outputs)))
|
||||
(self (match (derivation->output-paths drv)
|
||||
(((names . items) ...)
|
||||
items))))
|
||||
(remove (cut member <> self) refs)))
|
||||
|
||||
(define-syntax-rule (with-cache key exp ...)
|
||||
"Cache the value of monadic expression EXP under KEY."
|
||||
|
@ -231,15 +211,12 @@ (define (reference-origin drv item)
|
|||
(set-insert drv visited)))))))))
|
||||
|
||||
(define* (cumulative-grafts store drv grafts
|
||||
references
|
||||
#:key
|
||||
(outputs (derivation-output-names drv))
|
||||
(guile (%guile-for-build))
|
||||
(system (%current-system)))
|
||||
"Augment GRAFTS with additional grafts resulting from the application of
|
||||
GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure
|
||||
that returns the list of references of the store item it is given. Return the
|
||||
resulting list of grafts.
|
||||
GRAFTS to the dependencies of DRV. Return the resulting list of grafts.
|
||||
|
||||
This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping
|
||||
derivations to the corresponding set of grafts."
|
||||
|
@ -262,7 +239,7 @@ (define (dependency-grafts item)
|
|||
;; 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 references
|
||||
(cumulative-grafts store drv grafts
|
||||
#:outputs (list output)
|
||||
#:guile guile
|
||||
#:system system)))
|
||||
|
@ -270,7 +247,7 @@ (define (dependency-grafts item)
|
|||
(state-return grafts))))
|
||||
|
||||
(with-cache (cons (derivation-file-name drv) outputs)
|
||||
(match (non-self-references references drv outputs)
|
||||
(match (non-self-references store drv outputs)
|
||||
(() ;no dependencies
|
||||
(return grafts))
|
||||
(deps ;one or more dependencies
|
||||
|
@ -307,15 +284,8 @@ (define* (graft-derivation store drv grafts
|
|||
"Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
|
||||
That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
|
||||
DRV, and graft DRV itself to refer to those grafted dependencies."
|
||||
|
||||
;; First, pre-compute the dependency tree of the outputs of DRV. Do this
|
||||
;; upfront to have as much parallelism as possible when querying substitute
|
||||
;; info or when building DRV.
|
||||
(define references
|
||||
(references-oracle store (derivation-input drv outputs)))
|
||||
|
||||
(match (run-with-state
|
||||
(cumulative-grafts store drv grafts references
|
||||
(cumulative-grafts store drv grafts
|
||||
#:outputs outputs
|
||||
#:guile guile #:system system)
|
||||
vlist-null) ;the initial cache
|
||||
|
|
Loading…
Reference in a new issue