;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
package-patched-vulnerabilities
package-with-patches
package-with-extra-patches
+ package-with-c-toolchain
package/inherit
transitive-input-references
%supported-systems
%hurd-systems
- %hydra-supported-systems
+ %cuirass-supported-systems
supported-package?
&package-error
;;;
;;; Code:
+(define-syntax-rule (define-compile-time-decoder name string->bytevector)
+ "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
+if possible."
+ (define-syntax name
+ (lambda (s)
+ "Return the bytevector corresponding to the given textual
+representation."
+ (syntax-case s ()
+ ((_ str)
+ (string? (syntax->datum #'str))
+ ;; A literal string: do the conversion at expansion time.
+ (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
+ #''bv))
+ ((_ str)
+ #'(string->bytevector str))))))
+
+(define-compile-time-decoder base32 nix-base32-string->bytevector)
+(define-compile-time-decoder base64 base64-decode)
+
;; Crytographic content hash.
(define-immutable-record-type <content-hash>
(%content-hash algorithm value)
(define-content-hash-constructor build-content-hash
(sha256 32)
- (sha512 64))
+ (sha512 64)
+ (sha3-256 32)
+ (sha3-512 64)
+ (blake2s-256 64))
(define-syntax content-hash
(lambda (s)
(define (print-content-hash hash port)
(format port "#<content-hash ~a:~a>"
(content-hash-algorithm hash)
- (bytevector->nix-base32-string (content-hash-value hash))))
+ (and=> (content-hash-value hash)
+ bytevector->nix-base32-string)))
(set-record-type-printer! <content-hash> print-content-hash)
(set-record-type-printer! <origin> print-origin)
-(define-syntax-rule (define-compile-time-decoder name string->bytevector)
- "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
-if possible."
- (define-syntax name
- (lambda (s)
- "Return the bytevector corresponding to the given textual
-representation."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
- ;; A literal string: do the conversion at expansion time.
- (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
- #''bv))
- ((_ str)
- #'(string->bytevector str))))))
-
-(define-compile-time-decoder base32 nix-base32-string->bytevector)
-(define-compile-time-decoder base64 base64-decode)
-
(define (origin-actual-file-name origin)
"Return the file name of ORIGIN, either its 'file-name' field or the file
name of its URI."
(define %supported-systems
;; This is the list of system types that are supported. By default, we
;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
+ '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"
+ "powerpc64le-linux"))
(define %hurd-systems
;; The GNU/Hurd systems for which support is being developed.
'("i586-gnu" "i686-gnu"))
-(define %hydra-supported-systems
+(define %cuirass-supported-systems
;; This is the list of system types for which build machines are available.
;;
;; XXX: MIPS is unavailable in CI:
package)
16)))))
+(define-syntax-rule (package/inherit p overrides ...)
+ "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package P's replacement, if any. P must be a bare
+identifier, and will be bound to either P or its replacement when evaluating
+OVERRIDES."
+ (let loop ((p p))
+ (package (inherit p)
+ overrides ...
+ (replacement (and=> (package-replacement p) loop)))))
+
(define (package-upstream-name package)
"Return the upstream name of PACKAGE, which could be different from the name
it has in Guix."
(match (package-location package)
(($ <location> file line column)
- (catch 'system-error
- (lambda ()
- ;; In general we want to keep relative file names for modules.
- (call-with-input-file (search-path %load-path file)
- (lambda (port)
- (goto port line column)
- (match (read port)
- (('package inits ...)
- (let ((field (assoc field inits)))
- (match field
- ((_ value)
- (let ((loc (and=> (source-properties value)
- source-properties->location)))
- (and loc
- ;; Preserve the original file name, which may be a
- ;; relative file name.
- (set-field loc (location-file) file))))
- (_
- #f))))
- (_
- #f)))))
- (lambda _
- #f)))
+ (match (search-path %load-path file)
+ ((? string? file-found)
+ (catch 'system-error
+ (lambda ()
+ ;; In general we want to keep relative file names for modules.
+ (call-with-input-file file-found
+ (lambda (port)
+ (goto port line column)
+ (match (read port)
+ (('package inits ...)
+ (let ((field (assoc field inits)))
+ (match field
+ ((_ value)
+ (let ((loc (and=> (source-properties value)
+ source-properties->location)))
+ (and loc
+ ;; Preserve the original file name, which may be a
+ ;; relative file name.
+ (set-field loc (location-file) file))))
+ (_
+ #f))))
+ (_
+ #f)))))
+ (lambda _
+ #f)))
+ (#f
+ ;; FILE could not be found in %LOAD-PATH.
+ #f)))
(_ #f)))
(append (origin-patches (package-source original))
patches)))
+(define (package-with-c-toolchain package toolchain)
+ "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
+C/C++ toolchain. TOOLCHAIN must be a list of inputs (label/package tuples)
+providing equivalent functionality, such as the 'gcc-toolchain' package."
+ (let ((bs (package-build-system package)))
+ (package/inherit package
+ (build-system (build-system-with-c-toolchain bs toolchain)))))
+
(define (transitive-inputs inputs)
"Return the closure of INPUTS when considering the 'propagated-inputs'
edges. Omit duplicate inputs, except for those already present in INPUTS
(define (bag-transitive-inputs bag)
"Same as 'package-transitive-inputs', but applied to a bag."
- (parameterize ((%current-target-system #f))
+ (parameterize ((%current-target-system #f)
+ (%current-system (bag-system bag)))
(transitive-inputs (bag-direct-inputs bag))))
(define (bag-transitive-build-inputs bag)
"Same as 'package-transitive-native-inputs', but applied to a bag."
- (parameterize ((%current-target-system #f))
+ (parameterize ((%current-target-system #f)
+ (%current-system (bag-system bag)))
(transitive-inputs (bag-build-inputs bag))))
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
- (parameterize ((%current-target-system (bag-target bag)))
+ (parameterize ((%current-target-system (bag-target bag))
+ (%current-system (bag-system bag)))
(transitive-inputs (bag-host-inputs bag))))
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
- (parameterize ((%current-target-system (bag-target bag)))
+ (parameterize ((%current-target-system (bag-target bag))
+ (%current-system (bag-system bag)))
(transitive-inputs (bag-target-inputs bag))))
(define* (package-closure packages #:key (system (%current-system)))
(vhash-consq package #t visited)
(fold set-insert closure dependencies))))))))
-(define* (package-mapping proc #:optional (cut? (const #f)))
+(define (build-system-with-package-mapping bs rewrite)
+ "Return a variant of BS, a build system, that rewrites a bag's inputs by
+passing them through REWRITE, a procedure that takes an input tuplet and
+returns a \"rewritten\" input tuplet."
+ (define lower
+ (build-system-lower bs))
+
+ (define (lower* . args)
+ (let ((lowered (apply lower args)))
+ (bag
+ (inherit lowered)
+ (build-inputs (map rewrite (bag-build-inputs lowered)))
+ (host-inputs (map rewrite (bag-host-inputs lowered)))
+ (target-inputs (map rewrite (bag-target-inputs lowered))))))
+
+ (build-system
+ (inherit bs)
+ (lower lower*)))
+
+(define* (package-mapping proc #:optional (cut? (const #f))
+ #:key deep?)
"Return a procedure that, given a package, applies PROC to all the packages
depended on and returns the resulting package. The procedure stops recursion
-when CUT? returns true for a given package."
+when CUT? returns true for a given package. When DEEP? is true, PROC is
+applied to implicit inputs as well."
(define (rewrite input)
(match input
((label (? package? package) outputs ...)
- (let ((proc (if (cut? package) proc replace)))
- (cons* label (proc package) outputs)))
+ (cons* label (replace package) outputs))
(_
input)))
+ (define mapping-property
+ ;; Property indicating whether the package has already been processed.
+ (gensym " package-mapping-done"))
+
(define replace
(mlambdaq (p)
- ;; Return a variant of P with PROC applied to P and its explicit
- ;; dependencies, recursively. Memoize the transformations. Failing to
- ;; do that, we would build a huge object graph with lots of duplicates,
- ;; which in turns prevents us from benefiting from memoization in
- ;; 'package-derivation'.
- (let ((p (proc p)))
- (package
- (inherit p)
- (location (package-location p))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))
- (replacement (and=> (package-replacement p) proc))))))
+ ;; If P is the result of a previous call, return it.
+ (cond ((assq-ref (package-properties p) mapping-property)
+ p)
+
+ ((cut? p)
+ ;; Since P's propagated inputs are really inputs of its dependents,
+ ;; rewrite them as well, unless we're doing a "shallow" rewrite.
+ (let ((p (proc p)))
+ (if (or (not deep?)
+ (null? (package-propagated-inputs p)))
+ p
+ (package
+ (inherit p)
+ (location (package-location p))
+ (replacement (package-replacement p))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))
+
+ (else
+ ;; Return a variant of P with PROC applied to P and its explicit
+ ;; dependencies, recursively. Memoize the transformations. Failing
+ ;; to do that, we would build a huge object graph with lots of
+ ;; duplicates, which in turns prevents us from benefiting from
+ ;; memoization in 'package-derivation'.
+ (let ((p (proc p)))
+ (package
+ (inherit p)
+ (location (package-location p))
+ (build-system (if deep?
+ (build-system-with-package-mapping
+ (package-build-system p) rewrite)
+ (package-build-system p)))
+ (inputs (map rewrite (package-inputs p)))
+ (native-inputs (map rewrite (package-native-inputs p)))
+ (propagated-inputs (map rewrite (package-propagated-inputs p)))
+ (replacement (and=> (package-replacement p) replace))
+ (properties `((,mapping-property . #t)
+ ,@(package-properties p)))))))))
replace)
(define* (package-input-rewriting replacements
- #:optional (rewrite-name identity))
+ #:optional (rewrite-name identity)
+ #:key (deep? #t))
"Return a procedure that, when passed a package, replaces its direct and
-indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
-REPLACEMENTS is a list of package pairs; the first element of each pair is the
-package to replace, and the second one is the replacement.
+indirect dependencies, including implicit inputs when DEEP? is true, according
+to REPLACEMENTS. REPLACEMENTS is a list of package pairs; the first element
+of each pair is the package to replace, and the second one is the replacement.
Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
package and returns its new name after rewrite."
- (define (rewrite p)
- (match (assq-ref replacements p)
- (#f (package
- (inherit p)
- (name (rewrite-name (package-name p)))))
- (new new)))
+ (define replacement-property
+ ;; Property to tag right-hand sides in REPLACEMENTS.
+ (gensym " package-replacement"))
- (package-mapping rewrite (cut assq <> replacements)))
-
-(define (package-input-rewriting/spec replacements)
+ (define (rewrite p)
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (assq-ref replacements p)
+ (#f (package/inherit p
+ (name (rewrite-name (package-name p)))))
+ (new (if deep?
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new))))
+ new)))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (assq-ref replacements p)))
+
+ (package-mapping rewrite cut?
+ #:deep? deep?))
+
+(define* (package-input-rewriting/spec replacements #:key (deep? #t))
"Return a procedure that, given a package, applies the given REPLACEMENTS to
-all the package graph (excluding implicit inputs). REPLACEMENTS is a list of
-spec/procedures pair; each spec is a package specification such as \"gcc\" or
-\"guile@2\", and each procedure takes a matching package and returns a
-replacement for that package."
+all the package graph, including implicit inputs unless DEEP? is false.
+REPLACEMENTS is a list of spec/procedures pair; each spec is a package
+specification such as \"gcc\" or \"guile@2\", and each procedure takes a
+matching package and returns a replacement for that package."
(define table
(fold (lambda (replacement table)
(match replacement
(package-name package)
table))
- (define (rewrite package)
- (match (find-replacement package)
- (#f package)
- (proc (proc package))))
-
- (package-mapping rewrite find-replacement))
+ (define replacement-property
+ (gensym " package-replacement"))
-(define-syntax-rule (package/inherit p overrides ...)
- "Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any. P must be a bare
-identifier, and will be bound to either P or its replacement when evaluating
-OVERRIDES."
- (let loop ((p p))
- (package (inherit p)
- overrides ...
- (replacement (and=> (package-replacement p) loop)))))
+ (define (rewrite p)
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (find-replacement p)
+ (#f p)
+ (proc
+ (let ((new (proc p)))
+ ;; Mark NEW as already processed.
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new)))))))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (find-replacement p)))
+
+ (package-mapping rewrite cut?
+ #:deep? deep?))
\f
;;;
(make-weak-key-hash-table 200))
(define (input-graft store system)
- "Return a procedure that, given a package with a graft, returns a graft, and
-#f otherwise."
- (match-lambda
- ((? package? package)
+ "Return a procedure that, given a package with a replacement and an output name,
+returns a graft, and #f otherwise."
+ (match-lambda*
+ (((? package? package) output)
(let ((replacement (package-replacement package)))
(and replacement
- (cached (=> %graft-cache) package system
+ (cached (=> %graft-cache) package (cons output system)
(let ((orig (package-derivation store package system
#:graft? #f))
(new (package-derivation store replacement system
#:graft? #t)))
(graft
(origin orig)
- (replacement new)))))))
- (x
- #f)))
+ (origin-output output)
+ (replacement new)
+ (replacement-output output)))))))))
(define (input-cross-graft store target system)
"Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new))))))
- (_
- #f)))
+ (match-lambda*
+ (((? package? package) output)
+ (let ((replacement (package-replacement package)))
+ (and replacement
+ (let ((orig (package-cross-derivation store package target system
+ #:graft? #f))
+ (new (package-cross-derivation store replacement
+ target system
+ #:graft? #t)))
+ (graft
+ (origin orig)
+ (origin-output output)
+ (replacement new)
+ (replacement-output output))))))))
(define* (fold-bag-dependencies proc seed bag
#:key (native? #t))
(bag-host-inputs bag))))
bag-host-inputs))
- (define nodes
- (match (bag-direct-inputs* bag)
- (((labels things _ ...) ...)
- things)))
-
- (let loop ((nodes nodes)
+ (let loop ((inputs (bag-direct-inputs* bag))
(result seed)
- (visited (setq)))
- (match nodes
+ (visited vlist-null))
+ (match inputs
(()
result)
- (((? package? head) . tail)
- (if (set-contains? visited head)
- (loop tail result visited)
- (let ((inputs (bag-direct-inputs* (package->bag head))))
- (loop (match inputs
- (((labels things _ ...) ...)
- (append things tail)))
- (proc head result)
- (set-insert head visited)))))
+ (((label (? package? head) . rest) . tail)
+ (let ((output (match rest (() "out") ((output) output)))
+ (outputs (vhash-foldq* cons '() head visited)))
+ (if (member output outputs)
+ (loop tail result visited)
+ (let ((inputs (bag-direct-inputs* (package->bag head))))
+ (loop (append inputs tail)
+ (proc head output result)
+ (vhash-consq head output visited))))))
((head . tail)
(loop tail result visited)))))
(let ((->graft (input-graft store system)))
(parameterize ((%current-system system)
(%current-target-system #f))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
(#f grafts)
(graft (cons graft grafts))))
'()
(let ((->graft (input-cross-graft store target system)))
(parameterize ((%current-system system)
(%current-target-system target))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
+ (fold-bag-dependencies (lambda (package output grafts)
+ (match (->graft package output)
(#f grafts)
(graft (cons graft grafts))))
'()