[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/05: grafts: Avoid 'query-valid-derivers' RPC.
From: |
guix-commits |
Subject: |
02/05: grafts: Avoid 'query-valid-derivers' RPC. |
Date: |
Wed, 19 Jun 2019 16:56:57 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit aad086d8717d8ee6fa0ec37dd7932b74fe6398c3
Author: Ludovic Courtès <address@hidden>
Date: Wed Jun 19 21:50:45 2019 +0200
grafts: Avoid 'query-valid-derivers' RPC.
Previously we'd make 502 'query-valid-derivers' RPCs for
"guix build vim -d", and after this patch, we don't do any.
Furthermore, the previous strategy was "stateful" in the sense that
'item->deriver' could return a derivation that is not the one that was
actually computed by this process, but an "equivalent" one (due to
fixed-output derivations); which one is chosen would depend on the state
of the store.
This in turn means that we'd have to call 'read-derivation-from-file' to
actually read .drv files (as opposed to getting them from
%DERIVATION-CACHE). This is costly and doesn't work with
GUIX_DAEMON_SOCKET=ssh://….
* guix/grafts.scm (item->deriver): Remove.
(reference-origin): New procedure.
(cumulative-grafts): Use it instead of 'item->deriver'.
---
guix/grafts.scm | 67 ++++++++++++++++++++++++++++++++++-----------------------
1 file changed, 40 insertions(+), 27 deletions(-)
diff --git a/guix/grafts.scm b/guix/grafts.scm
index a3e12f6..3b43e11 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès
<address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,9 +22,9 @@
#:use-module (guix records)
#:use-module (guix derivations)
#:use-module ((guix utils) #:select (%current-system))
+ #:use-module (guix sets)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 match)
@@ -151,21 +151,6 @@ are not recursively applied to dependencies of DRV."
#:substitutable? #f
#:properties properties)))))
-(define (item->deriver store item)
- "Return two values: the derivation that led to ITEM (a store item), and the
-name of the output of that derivation ITEM corresponds to (for example
-\"out\"). When ITEM has no deriver, for instance because it is a plain file,
-#f and #f are returned."
- (match (valid-derivers store item)
- (() ;ITEM is a plain file
- (values #f #f))
- ((drv-file _ ...)
- (let ((drv (read-derivation-from-file drv-file)))
- (values drv
- (any (match-lambda
- ((name . path)
- (and (string=? item path) name)))
- (derivation->output-paths drv)))))))
(define (non-self-references references drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
@@ -230,6 +215,33 @@ available."
(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."
+ ;; Perform a breadth-first traversal of the dependency graph of DRV in
+ ;; search of the derivation that produces ITEM.
+ (let loop ((drv (list drv))
+ (visited (setq)))
+ (match drv
+ (()
+ #f)
+ ((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)))))))))
+
(define* (cumulative-grafts store drv grafts
references
#:key
@@ -257,16 +269,17 @@ derivations to the corresponding set of grafts."
#f)))
(define (dependency-grafts item)
- (let-values (((drv output) (item->deriver store item)))
- (if drv
- ;; 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
- #:outputs (list output)
- #:guile guile
- #:system system))
- (state-return grafts))))
+ (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 references
+ #:outputs (list output)
+ #:guile guile
+ #:system system)))
+ (#f
+ (state-return grafts))))
(with-cache (cons (derivation-file-name drv) outputs)
(match (non-self-references references drv outputs)