From 05962f2958eb98bad384702455236ff9d2acfb39 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Oct 2014 18:09:00 +0100 Subject: packages: Implement grafts. Thanks to Mark H. Weaver for insightful discussions and suggestions. * guix/packages.scm ()[graft]: New field. (patch-and-repack): Invoke 'package-derivation' with #:graft? #f. (package-source-derivation): Likewise. Do not use (%guile-for-build) in call to 'patch-and-repack', and we could end up using a grafted Guile. (expand-input): Likewise, also for 'package-cross-derivation' call. (package->bag): Add #:graft? parameter. Honor it. Use 'strip-append' instead of 'package-full-name'. (input-graft, input-cross-graft, bag-grafts, package-grafts): New procedures. (package-derivation, package-cross-derivation): Add #:graft? parameter and honor it. * gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Add recursive call on 'graft'. * guix/build-system/gnu.scm (package-with-explicit-inputs, package-with-extra-configure-variable, static-package): Likewise. (gnu-build): Use the ungrafted Guile to avoid full rebuilds. (gnu-cross-build): Likewise. * guix/build-system/cmake.scm (cmake-build): Likewise. * guix/build-system/glib-or-gtk.scm (glib-or-gtk-build): Likewise. * guix/build-system/perl.scm (perl-build): Likewise. * guix/build-system/python.scm (python-build): Likewise. * guix/build-system/ruby.scm (ruby-build): Likewise. * guix/build-system/trivial.scm (guile-for-build): Likewise. * tests/packages.scm ("package-derivation, direct graft", "package-cross-derivation, direct graft", "package-grafts, indirect grafts", "package-grafts, indirect grafts, cross", "package-grafts, indirect grafts, propagated inputs", "package-derivation, indirect grafts"): New tests. ("bag->derivation", "bag->derivation, cross-compilation"): Wrap in 'parameterize'. * doc/guix.texi (Security Updates): New node. (Invoking guix build): Document --no-graft. --- guix/packages.scm | 147 ++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 127 insertions(+), 20 deletions(-) (limited to 'guix/packages.scm') diff --git a/guix/packages.scm b/guix/packages.scm index 97a82a4682..698a4c8097 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -26,6 +26,7 @@ (define-module (guix packages) #:use-module (ice-9 match) #: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 (srfi srfi-35) @@ -65,6 +66,7 @@ (define-module (guix packages) package-outputs package-native-search-paths package-search-paths + package-replacement package-synopsis package-description package-license @@ -85,6 +87,7 @@ (define-module (guix packages) package-derivation package-cross-derivation package-output + package-grafts %supported-systems @@ -97,6 +100,7 @@ (define-module (guix packages) &package-cross-build-system-error package-cross-build-system-error? + %graft? package->bag bag->derivation bag-transitive-inputs @@ -211,6 +215,8 @@ (define-record-type* ; inputs (native-search-paths package-native-search-paths (default '())) (search-paths package-search-paths (default '())) + (replacement package-replacement ; package | #f + (default #f) (thunked)) (synopsis package-synopsis) ; one-line description (description package-description) ; one or two paragraphs @@ -445,8 +451,8 @@ (define (first-file directory) (and (member name (cons decompression-type '("tar" "xz" "patch"))) (list name - (package-derivation store p - system))))) + (package-derivation store p system + #:graft? #f))))) (or inputs (%standard-patch-inputs)))) (modules (delete-duplicates (cons '(guix build utils) modules)))) @@ -472,12 +478,10 @@ (define* (package-source-derivation store source ;; Patches and/or a snippet. (let ((source (method store uri 'sha256 sha256 name #:system system)) - (guile (match (or guile-for-build (%guile-for-build) - (default-guile)) + (guile (match (or guile-for-build (default-guile)) ((? package? p) - (package-derivation store p system)) - ((? derivation? drv) - drv)))) + (package-derivation store p system + #:graft? #f))))) (patch-and-repack store source patches #:inputs inputs #:snippet snippet @@ -617,8 +621,9 @@ (define (intern file) (define derivation (if cross-system - (cut package-cross-derivation store <> cross-system system) - (cut package-derivation store <> system))) + (cut package-cross-derivation store <> cross-system system + #:graft? #f) + (cut package-derivation store <> system #:graft? #f))) (match input (((? string? name) (? package? package)) @@ -643,20 +648,27 @@ (define derivation (package package) (input x))))))) +(define %graft? + ;; Whether to honor package grafts by default. + (make-parameter #t)) + (define* (package->bag package #:optional (system (%current-system)) - (target (%current-target-system))) + (target (%current-target-system)) + #:key (graft? (%graft?))) "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, and return it." ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field ;; values can refer to it. (parameterize ((%current-system system) (%current-target-system target)) - (match package + (match (if graft? + (or (package-replacement package) package) + package) (($ name version source build-system args inputs propagated-inputs native-inputs self-native-input? outputs) - (or (make-bag build-system (package-full-name package) + (or (make-bag build-system (string-append name "-" version) #:system system #:target target #:source source @@ -676,6 +688,77 @@ (define* (package->bag package #:optional (&package-error (package package)))))))))) +(define (input-graft store system) + "Return a procedure that, given an input referring to a package with a +graft, returns a pair with the original derivation and the graft's derivation, +and returns #f for other inputs." + (match-lambda + ((label (? package? package) sub-drv ...) + (let ((replacement (package-replacement package))) + (and replacement + (let ((orig (package-derivation store package system + #:graft? #f)) + (new (package-derivation store replacement system))) + (graft + (origin orig) + (replacement new) + (origin-output (match sub-drv + (() "out") + ((output) output))) + (replacement-output origin-output)))))) + (x + #f))) + +(define (input-cross-graft store target system) + "Same as 'input-graft', but for cross-compilation inputs." + (match-lambda + ((label (? package? package) sub-drv ...) + (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 + (origin orig) + (replacement new) + (origin-output (match sub-drv + (() "out") + ((output) output))) + (replacement-output origin-output)))))) + (_ + #f))) + +(define* (bag-grafts store bag) + "Return the list of grafts applicable to BAG. Each graft is a +record." + (let ((target (bag-target bag)) + (system (bag-system bag))) + (define native-grafts + (filter-map (input-graft store system) + (append (bag-transitive-build-inputs bag) + (bag-transitive-target-inputs bag) + (if target + '() + (bag-transitive-host-inputs bag))))) + + (define target-grafts + (if target + (filter-map (input-cross-graft store target system) + (bag-transitive-host-inputs bag)) + '())) + + (append native-grafts target-grafts))) + +(define* (package-grafts store package + #:optional (system (%current-system)) + #:key target) + "Return the list of grafts applicable to PACKAGE as built for SYSTEM and +TARGET." + (let* ((package (or (package-replacement package) package)) + (bag (package->bag package system target))) + (bag-grafts store bag))) + (define* (bag->derivation store bag #:optional context) "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be @@ -743,23 +826,47 @@ (define* (bag->cross-derivation store bag (bag-arguments bag)))) (define* (package-derivation store package - #:optional (system (%current-system))) + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Return the object of PACKAGE for SYSTEM." ;; Compute the derivation and cache the result. Caching is important ;; because some derivations, such as the implicit inputs of the GNU build ;; system, will be queried many, many times in a row. - (cached package system - (bag->derivation store (package->bag package system #f) - package))) + (cached package (cons system graft?) + (let* ((bag (package->bag package system #f #:graft? graft?)) + (drv (bag->derivation store bag package))) + (if graft? + (match (bag-grafts store bag) + (() + drv) + (grafts + (let ((guile (package-derivation store (default-guile) + system #:graft? #f))) + (graft-derivation store (bag-name bag) drv grafts + #:system system + #:guile guile)))) + drv)))) (define* (package-cross-derivation store package target - #:optional (system (%current-system))) + #:optional (system (%current-system)) + #:key (graft? (%graft?))) "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix system identifying string)." - (cached package (cons system target) - (bag->derivation store (package->bag package system target) - package))) + (cached package (list system target graft?) + (let* ((bag (package->bag package system target #:graft? graft?)) + (drv (bag->derivation store bag package))) + (if graft? + (match (bag-grafts store bag) + (() + drv) + (grafts + (graft-derivation store (bag-name bag) drv grafts + #:system system + #:guile + (package-derivation store (default-guile) + system #:graft? #f)))) + drv)))) (define* (package-output store package #:optional (output "out") (system (%current-system))) -- cgit v1.2.3