;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 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* (graft-derivation/shallow store drv grafts
#:key
(name (derivation-name drv))
+ (outputs (derivation-output-names drv))
(guile (%guile-for-build))
(system (%current-system)))
- "Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied. This procedure performs \"shallow\" grafting in that GRAFTS are not
-recursively applied to dependencies of DRV."
+ "Return a derivation called NAME, which applies GRAFTS to the specified
+OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS
+are not recursively applied to dependencies of DRV."
;; XXX: Someday rewrite using gexps.
(define mapping
;; List of store item pairs.
target))))
grafts))
- (define outputs
- (map (match-lambda
- ((name . output)
- (cons name (derivation-output-path output))))
- (derivation-outputs drv)))
-
- (define output-names
- (derivation-output-names drv))
+ (define output-pairs
+ (map (lambda (output)
+ (cons output
+ (derivation-output-path
+ (assoc-ref (derivation-outputs drv) output))))
+ outputs))
(define build
`(begin
(guix build utils)
(ice-9 match))
- (let* ((old-outputs ',outputs)
+ (let* ((old-outputs ',output-pairs)
(mapping (append ',mapping
(map (match-lambda
((name . file)
(cons (assoc-ref old-outputs name)
file)))
%outputs))))
- (for-each (lambda (input output)
- (format #t "grafting '~a' -> '~a'...~%" input output)
- (force-output)
- (rewrite-directory input output mapping))
- (match old-outputs
- (((names . files) ...)
- files))
- (match %outputs
- (((names . files) ...)
- files))))))
+ (graft old-outputs %outputs mapping))))
(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))
#:system system
#:guile-for-build guile
#:modules '((guix build graft)
- (guix build utils))
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf))
#:inputs `(,@(map (lambda (out)
`("x" ,drv ,out))
- output-names)
+ outputs)
,@(append (map add-label sources)
(map add-label targets)))
- #:outputs output-names
- #: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 (call-with-input-file drv-file read-derivation)))
- (values drv
- (any (match-lambda
- ((name . path)
- (and (string=? item path) name)))
- (derivation->output-paths drv)))))))
+ #:outputs outputs
+
+ ;; 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
(()
(delete-duplicates (concatenate refs) string=?))
result))))))
+(define-syntax-rule (with-cache key exp ...)
+ "Cache the value of monadic expression EXP under KEY."
+ (mlet %state-monad ((cache (current-state)))
+ (match (vhash-assoc key cache)
+ ((_ . result) ;cache hit
+ (return result))
+ (#f ;cache miss
+ (mlet %state-monad ((result (begin exp ...))
+ (cache (current-state)))
+ (mbegin %state-monad
+ (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))))
-
- (define (return/cache cache value)
- (mbegin %state-monad
- (set-current-state (vhash-consq drv value cache))
- (return value)))
-
- (mlet %state-monad ((cache (current-state)))
- (match (vhash-assq drv cache)
- ((_ . grafts) ;hit
+ (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)
+ (() ;no dependencies
(return grafts))
- (#f ;miss
- (match (non-self-references references drv outputs)
- (() ;no dependencies
- (return/cache cache grafts))
- (deps ;one or more dependencies
- (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
- (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
- (match (filter (lambda (graft)
- (member (graft-origin-file-name graft) deps))
- grafts)
- (()
- (return/cache cache grafts))
- ((applicable ..1)
- ;; Use APPLICABLE, the subset of GRAFTS that is really
- ;; applicable to DRV, to avoid creating several identical
- ;; grafted variants of DRV.
- (let* ((new (graft-derivation/shallow store drv applicable
- #:guile guile
- #:system system))
- (grafts (cons (graft (origin drv) (replacement new))
- grafts)))
- (return/cache cache grafts))))))))))))
+ (deps ;one or more dependencies
+ (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)))
+ (let ((grafts (delete-duplicates (concatenate grafts) equal?)))
+ (match (filter (lambda (graft)
+ (member (graft-origin-file-name graft) deps))
+ grafts)
+ (()
+ (return grafts))
+ ((applicable ..1)
+ ;; Use APPLICABLE, the subset of GRAFTS that is really
+ ;; applicable to DRV, to avoid creating several identical
+ ;; grafted variants of DRV.
+ (let* ((new (graft-derivation/shallow store drv applicable
+ #:outputs outputs
+ #:guile guile
+ #:system system))
+ (grafts (append (map (lambda (output)
+ (graft
+ (origin drv)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output)))
+ outputs)
+ grafts)))
+ (return grafts))))))))))
(define* (graft-derivation store drv grafts
- #:key (guile (%guile-for-build))
+ #:key
+ (guile (%guile-for-build))
+ (outputs (derivation-output-names drv))
(system (%current-system)))
- "Applied GRAFTS to DRV and all its 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."
+ "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 drv))
+ (references-oracle store (derivation-input drv outputs)))
(match (run-with-state
(cumulative-grafts store drv grafts references
+ #:outputs outputs
#:guile guile #:system system)
vlist-null) ;the initial cache
((first . rest)
(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:
+
;;; grafts.scm ends here