;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
#:use-module (guix memoization)
#:use-module (guix combinators)
#:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (guix monads)
#:use-module (gcrypt hash)
#:use-module (guix base32)
derivation-input-derivation
derivation-input-sub-derivations
derivation-input-output-paths
+ derivation-input-output-path
valid-derivation-input?
&derivation-error
fixed-output-derivation?
offloadable-derivation?
substitutable-derivation?
+ derivation-input-fold
substitution-oracle
derivation-hash
derivation-properties
(map (cut derivation->output-path drv <>)
sub-drvs))))
+(define (derivation-input-output-path input)
+ "Return the output file name of INPUT. If INPUT has more than one outputs,
+an error is raised."
+ (match input
+ (($ <derivation-input> drv (output))
+ (derivation->output-path drv output))))
+
(define (valid-derivation-input? store input)
"Return true if INPUT is valid--i.e., if all the outputs it requests are in
the store."
"Return a list of inputs, such that when INPUTS contains the same DRV twice,
they are coalesced, with their sub-derivations merged. This is needed because
Nix itself keeps only one of them."
+ (define (find pred lst) ;inlinable copy of 'find'
+ (let loop ((lst lst))
+ (match lst
+ (() #f)
+ ((head . tail)
+ (if (pred head) head (loop tail))))))
+
(fold (lambda (input result)
(match input
(($ <derivation-input> (= derivation-file-name path) sub-drvs)
(derivation-output-path (assoc-ref outputs sub-drv)))
sub-drvs))))
-(define* (substitution-oracle store drv
+(define* (derivation-input-fold proc seed inputs
+ #:key (cut? (const #f)))
+ "Perform a breadth-first traversal of INPUTS, calling PROC on each input
+with the current result, starting from SEED. Skip recursion on inputs that
+match CUT?."
+ (let loop ((inputs inputs)
+ (result seed)
+ (visited (set)))
+ (match inputs
+ (()
+ result)
+ ((input rest ...)
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest result visited))
+ ((cut? input)
+ (loop rest result (set-insert key visited)))
+ (else
+ (let ((drv (derivation-input-derivation input)))
+ (loop (append (derivation-inputs drv) rest)
+ (proc input result)
+ (set-insert key visited))))))))))
+
+(define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
returns a 'substitutable?' if it's substitutable and #f otherwise.
-The returned procedure
-knows about all substitutes for all the derivations listed in DRV, *except*
-those that are already valid (that is, it won't bother checking whether an
-item is substitutable if it's already on disk); it also knows about their
-prerequisites, unless they are themselves substitutable.
+
+The returned procedure knows about all substitutes for all the derivation
+inputs or derivations listed in INPUTS-OR-DRV, *except* those that are already
+valid (that is, it won't bother checking whether an item is substitutable if
+it's already on disk); it also knows about their prerequisites, unless they
+are themselves substitutable.
Creating a single oracle (thus making a single 'substitutable-path-info' call) and
reusing it is much more efficient than calling 'has-substitutes?' or similar
repeatedly, because it avoids the costs associated with launching the
substituter many times."
- (define valid?
- (cut valid-path? store <>))
-
(define valid-input?
(cut valid-derivation-input? store <>))
- (define (dependencies drv)
- ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us
- ;; to ask the substituter for just as much as needed, instead of asking it
- ;; for the whole world, which can be significantly faster when substitute
- ;; info is not already in cache.
- ;; Also, skip derivations marked as non-substitutable.
- (append-map (lambda (input)
- (let ((drv (derivation-input-derivation input)))
- (if (substitutable-derivation? drv)
- (derivation-input-output-paths input)
- '())))
- (derivation-prerequisites drv valid-input?)))
-
- (let* ((paths (delete-duplicates
- (concatenate
- (fold (lambda (drv result)
- (let ((self (match (derivation->output-paths drv)
- (((names . paths) ...)
- paths))))
- (cond ((eqv? mode (build-mode check))
- (cons (dependencies drv) result))
- ((not (substitutable-derivation? drv))
- (cons (dependencies drv) result))
- ((every valid? self)
- result)
- (else
- (cons* self (dependencies drv) result)))))
- '()
- drv))))
- (subst (fold (lambda (subst vhash)
- (vhash-cons (substitutable-path subst) subst
- vhash))
- vlist-null
- (substitutable-path-info store paths))))
+ (define (closure inputs)
+ (reverse
+ (derivation-input-fold (lambda (input closure)
+ (let ((drv (derivation-input-derivation input)))
+ (if (substitutable-derivation? drv)
+ (cons input closure)
+ closure)))
+ '()
+ inputs
+ #:cut? valid-input?)))
+
+ (let* ((inputs (closure (map (match-lambda
+ ((? derivation-input? input)
+ input)
+ ((? derivation? drv)
+ (derivation-input drv)))
+ inputs-or-drv)))
+ (items (append-map derivation-input-output-paths inputs))
+ (subst (fold (lambda (subst vhash)
+ (vhash-cons (substitutable-path subst) subst
+ vhash))
+ vlist-null
+ (substitutable-path-info store items))))
(lambda (item)
(match (vhash-assoc item subst)
(#f #f)
((key . value) value)))))
+(define (dependencies-of-substitutables substitutables inputs)
+ "Return the subset of INPUTS whose output file names is among the references
+of SUBSTITUTABLES."
+ (let ((items (fold set-insert (set)
+ (append-map substitutable-references substitutables))))
+ (filter (lambda (input)
+ (any (cut set-contains? items <>)
+ (derivation-input-output-paths input)))
+ inputs)))
+
(define* (derivation-build-plan store inputs
#:key
(mode (build-mode normal))
(substitutable-info
(substitution-oracle
- store
- (map derivation-input-derivation
- inputs)
- #:mode mode)))
+ store inputs #:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of
-derivation to build, and the list of substitutable items that, together,
-allows INPUTS to be realized.
+derivations to build, and the list of substitutable items that, together,
+allow INPUTS to be realized.
SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
by 'substitution-oracle'."
(()
(values build substitute))
((input rest ...)
- (let ((key (derivation-input-key input)))
+ (let ((key (derivation-input-key input))
+ (deps (derivation-inputs
+ (derivation-input-derivation input))))
(cond ((set-contains? visited key)
(loop rest build substitute visited))
((input-built? input)
((input-substitutable-info input)
=>
(lambda (substitutables)
- (loop rest build
+ (loop (append (dependencies-of-substitutables substitutables
+ deps)
+ rest)
+ build
(append substitutables substitute)
(set-insert key visited))))
(else
- (let ((deps (derivation-inputs
- (derivation-input-derivation input))))
- (loop (append deps rest)
- (cons (derivation-input-derivation input) build)
- substitute
- (set-insert key visited))))))))))
+ (loop (append deps rest)
+ (cons (derivation-input-derivation input) build)
+ substitute
+ (set-insert key visited)))))))))
(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
derivation-build-plan
(display ")" port))))
(define derivation->bytevector
- (mlambda (drv)
+ (lambda (drv)
"Return the external representation of DRV as a UTF-8-encoded string."
(with-fluids ((%default-port-encoding "UTF-8"))
(call-with-values open-bytevector-output-port
(make-derivation-input hash sub-drvs))))
inputs)))
(make-derivation outputs
- (sort inputs
+ (sort (delete-duplicates inputs)
(lambda (drv1 drv2)
(string<? (derivation-input-derivation drv1)
(derivation-input-derivation drv2))))
;; character.
(sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
+
+(define (warn-about-derivation-deprecation name)
+ ;; TRANSLATORS: 'derivation' must not be translated; it refers to the
+ ;; 'derivation' procedure.
+ (warning (G_ "in '~a': deprecated 'derivation' calling convention used~%")
+ name))
+
(define* (derivation store name builder args
#:key
(system (%current-system)) (env-vars '())
- (inputs '()) (outputs '("out"))
+ (inputs '()) (sources '())
+ (outputs '("out"))
hash hash-algo recursive?
references-graphs
allowed-references disallowed-references
leaked-env-vars local-build?
(substitutable? #t)
- (properties '()))
+ (properties '())
+ (%deprecation-warning? #t))
"Build a derivation with the given arguments, and return the resulting
<derivation> object. When HASH and HASH-ALGO are given, a
fixed-output derivation is created---i.e., one whose result is known in
e
outputs)))
+ (define-syntax-rule (warn-deprecation name)
+ (when %deprecation-warning?
+ (warn-about-derivation-deprecation name)))
+
(define input->derivation-input
(match-lambda
+ ((? derivation-input? input)
+ input)
(((? derivation? drv))
+ (warn-deprecation name)
(make-derivation-input drv '("out")))
(((? derivation? drv) sub-drvs ...)
+ (warn-deprecation name)
(make-derivation-input drv sub-drvs))
- (_ #f)))
+ (_
+ (warn-deprecation name)
+ #f)))
(define input->source
(match-lambda
(((? string? input) . _)
+ (warn-deprecation name)
(if (direct-store-path? input)
input
(add-to-store store (basename input)
hash recursive?)))
(sort outputs string<?)))
(sources (sort (delete-duplicates
- (filter-map input->source inputs))
+ (append (filter-map input->source inputs)
+ sources))
string<?))
(inputs (sort (coalesce-duplicate-inputs
(filter-map input->derivation-input inputs))
long-running processes that know what they're doing. Use with care!"
;; Typically this is meant to be used by Cuirass and Hydra, which can clear
;; caches when they start evaluating packages for another architecture.
- (invalidate-memoization! derivation->bytevector)
(invalidate-memoization! derivation-base16-hash)
;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
(define input->output-paths
(match-lambda
- (((? derivation? drv))
- (list (derivation->output-path drv)))
- (((? derivation? drv) sub-drvs ...)
- (map (cut derivation->output-path drv <>)
- sub-drvs))
- ((file)
- (list file))))
+ ((? derivation-input? input)
+ (derivation-input-output-paths input))
+ ((? string? file)
+ (list file))))
(let ((mapping (fold (lambda (pair result)
(match pair
(($ <derivation-input> drv (sub-drvs ...))
(match (vhash-assoc (derivation-file-name drv) mapping)
((_ . (? derivation? replacement))
- (cons replacement sub-drvs))
- ((_ . replacement)
- (list replacement))
+ (derivation-input replacement sub-drvs))
+ ((_ . (? string? source))
+ source)
(#f
- (cons (loop drv) sub-drvs)))))))
+ (derivation-input (loop drv) sub-drvs)))))))
(let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop)
. ,(substitute value initial
replacements))))
(derivation-builder-environment-vars drv))
- #:inputs (append (map list sources) inputs)
+ #:inputs (filter derivation-input? inputs)
+ #:sources (append sources (filter string? inputs))
#:outputs (derivation-output-names drv)
#:hash (match (derivation-outputs drv)
((($ <derivation-output> _ algo hash))
(string-tokenize (dirname file-name) not-slash))))))
(define* (imported-files store files ;deprecated
- #:key (name "file-import")
- (system (%current-system))
- (guile (%guile-for-build)))
- "Return a derivation that imports FILES into STORE. FILES must be a list
+ #:key (name "file-import"))
+ "Return a store item that contains FILES. FILES must be a list
of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
system, imported, and appears under FINAL-PATH in the resulting store path."
- (let* ((files (map (match-lambda
- ((final-path . file-name)
- (list final-path
- (add-to-store store (basename final-path) #f
- "sha256" file-name))))
- files))
- (builder
- `(begin
- (mkdir %output) (chdir %output)
- ,@(append-map (match-lambda
- ((final-path store-path)
- (append (match (parent-directories final-path)
- (() '())
- ((head ... tail)
- (append (map (lambda (d)
- `(false-if-exception
- (mkdir ,d)))
- head)
- `((or (file-exists? ,tail)
- (mkdir ,tail))))))
- `((symlink ,store-path ,final-path)))))
- files))))
- (build-expression->derivation store name builder
- #:system system
- #:inputs files
- #:guile-for-build guile
- #:local-build? #t)))
+ (add-file-tree-to-store store
+ `(,name directory
+ ,@(file-mapping->tree files))))
;; The "file not found" error condition.
(define-condition-type &file-search-error &error
(define* (%imported-modules store modules ;deprecated
#:key (name "module-import")
- (system (%current-system))
- (guile (%guile-for-build))
(module-path %load-path))
- "Return a derivation that contains the source files of MODULES, a list of
+ "Return a store item that contains the source files of MODULES, a list of
module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
search path."
;; TODO: Determine the closure of MODULES, build the `.go' files,
(let ((f (module->source-file-name m)))
(cons f (search-path* module-path f))))
modules)))
- (imported-files store files #:name name #:system system
- #:guile guile)))
+ (imported-files store files #:name name)))
(define* (%compiled-modules store modules ;deprecated
#:key (name "module-import-compiled")
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other."
- (let* ((module-drv (%imported-modules store modules
- #:system system
- #:guile guile
+ (let* ((module-dir (%imported-modules store modules
#:module-path module-path))
- (module-dir (derivation->output-path module-drv))
(files (map (lambda (m)
(let ((f (string-join (map symbol->string m)
"/")))
files)))
(build-expression->derivation store name builder
- #:inputs `(("modules" ,module-drv))
+ #:inputs `(("modules" ,module-dir))
#:system system
#:guile-for-build guile
#:local-build? #t)))
+(define %module-cache
+ ;; Map a list of modules to its 'imported+compiled-modules' result.
+ (make-hash-table))
+
+(define* (imported+compiled-modules store modules #:key
+ (system (%current-system))
+ (guile (%guile-for-build)))
+ "Return a pair containing the derivation to import MODULES and that where
+MODULES are compiled."
+ (define key
+ (list modules (derivation-file-name guile) system))
+
+ (or (hash-ref %module-cache key)
+ (let ((result (cons (%imported-modules store modules)
+ (%compiled-modules store modules
+ #:system system #:guile guile))))
+ (hash-set! %module-cache key result)
+ result)))
+
(define* (build-expression->derivation store name exp ;deprecated
#:key
(system (%current-system))
;; fixed-output.
(filter-map source-path inputs)))
- (mod-drv (and (pair? modules)
- (%imported-modules store modules
- #:guile guile-drv
- #:system system)))
- (mod-dir (and mod-drv
- (derivation->output-path mod-drv)))
- (go-drv (and (pair? modules)
- (%compiled-modules store modules
- #:guile guile-drv
- #:system system)))
+ (mod+go-drv (if (pair? modules)
+ (imported+compiled-modules store modules
+ #:guile guile-drv
+ #:system system)
+ '(#f . #f)))
+ (mod-dir (car mod+go-drv))
+ (go-drv (cdr mod+go-drv))
(go-dir (and go-drv
(derivation->output-path go-drv))))
(derivation store name guile
,@(if mod-dir `("-L" ,mod-dir) '())
,builder)
+ ;; 'build-expression->derivation' is somewhat deprecated so
+ ;; don't bother warning here.
+ #:%deprecation-warning? #f
+
#:system system
#:inputs `((,(or guile-for-build (%guile-for-build)))
(,builder)
,@(map cdr inputs)
- ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
+ ,@(if mod-dir `((,mod-dir) (,go-drv)) '()))
;; When MODULES is non-empty, shamelessly clobber
;; $GUILE_LOAD_COMPILED_PATH.
HCoop / jackhill / guix / guix.git / blobdiff