;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
graft-derivation/shallow
%graft?
- set-grafting))
+ set-grafting
+ grafting?))
(define-record-type* <graft> graft make-graft
graft?
(define add-label
(cut cons "x" <>))
+ (define properties
+ `((type . graft)
+ (graft (count . ,(length grafts)))))
+
(match grafts
((($ <graft> sources source-outputs targets target-outputs) ...)
(let ((sources (zip sources source-outputs))
,@(append (map add-label sources)
(map add-label targets)))
#:outputs outputs
- #:local-build? #t)))))
-(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)))))))
+
+ ;; Grafts are computationally cheap so no
+ ;; need to offload or substitute.
+ #:local-build? #t
+ #:substitutable? #f
+
+ #:properties properties)))))
(define (non-self-references references drv outputs)
"Return the list of references of the OUTPUTS of DRV, excluding self
items))))
(remove (cut member <> self) refs)))
-(define (references-oracle store drv)
- "Return a one-argument procedure that, when passed the file name of DRV's
-outputs or their dependencies, returns the list of references of that item.
-Use either local info or substitute info; build DRV if no information is
-available."
- (define (output-paths drv)
- (match (derivation->output-paths drv)
- (((names . items) ...)
- items)))
-
+(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. Use either local info or substitute info; build
+INPUT if no information is available."
(define (references* items)
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
;; As a last resort, build DRV and query the references of the
;; build result.
;; Warm up the narinfo cache, otherwise each derivation build
;; will result in one HTTP request to get one narinfo, which is
;; much less efficient than fetching them all upfront.
- (substitution-oracle store (list drv))
+ (substitution-oracle store
+ (list (derivation-input-derivation input)))
- (and (build-derivations store (list drv))
+ (and (build-derivations store (list input))
(map (cut references store <>) items))))
(references/substitutes store items)))
- (let loop ((items (output-paths drv))
+ (let loop ((items (derivation-input-output-paths input))
(result vlist-null))
(match items
(()
(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
#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)
;; upfront to have as much parallelism as possible when querying substitute
;; info or when building DRV.
(define references
- (references-oracle store drv))
+ (references-oracle store (derivation-input drv outputs)))
(match (run-with-state
(cumulative-grafts store drv grafts references
(lambda (store)
(values (%graft? enable?) store)))
+(define (grafting?)
+ "Return a Boolean indicating whether grafting is enabled."
+ (lambda (store)
+ (values (%graft?) store)))
+
;; Local Variables:
;; eval: (put 'with-cache 'scheme-indent-function 1)
;; End:
HCoop / jackhill / guix / guix.git / blobdiff