aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-10-17 23:55:38 +0200
committerLudovic Courtès <ludo@gnu.org>2012-10-18 23:18:38 +0200
commitd6e877768821da5859d0c5774d4cea57941fde8b (patch)
tree82716ec6ef9f763da314fc300d7fade588cf7056
parentd14ecda913be98151f9c92f5f35e88cdb3457580 (diff)
downloadguix-d6e877768821da5859d0c5774d4cea57941fde8b.tar
guix-d6e877768821da5859d0c5774d4cea57941fde8b.tar.gz
distro: Use the bootstrap Guile for the derivation of sources.
* distro/packages/base.scm (bootstrap-origin, package-with-bootstrap-guile): New procedures. (gnu-make-boot0, diffutils-boot0, findutils-boot0, binutils-boot0, gcc-boot0, linux-libre-headers-boot0, glibc-final, bash-final, guile-final): Use `package-with-bootstrap-guile'. (gcc-boot0-wrapped): Clear `source'. * guix/ftp.scm (ftp-fetch): Add a #:guile keyword parameter. Honor it. * guix/http.scm (http-fetch): Likewise.
-rw-r--r--distro/packages/base.scm402
-rw-r--r--guix/ftp.scm20
-rw-r--r--guix/http.scm21
3 files changed, 263 insertions, 180 deletions
diff --git a/distro/packages/base.scm b/distro/packages/base.scm
index 318af1c4ab..5f23bc0064 100644
--- a/distro/packages/base.scm
+++ b/distro/packages/base.scm
@@ -1424,6 +1424,46 @@ $out/bin/guile --version~%"
(home-page #f)
(license "LGPLv3+"))))
+(define (bootstrap-origin source)
+ "Return a variant of SOURCE, an <origin> instance, whose method uses
+%BOOTSTRAP-GUILE to do its job."
+ (define (boot fetch)
+ (lambda* (store url hash-algo hash #:optional name)
+ (fetch store url hash-algo hash
+ #:guile %bootstrap-guile)))
+
+ (let ((orig-method (origin-method source)))
+ (origin (inherit source)
+ (method (cond ((eq? orig-method http-fetch)
+ (boot http-fetch))
+ ((eq? orig-method ftp-fetch)
+ (boot ftp-fetch))
+ (else orig-method))))))
+
+(define package-with-bootstrap-guile
+ (memoize
+ (lambda (p)
+ "Return a variant of P such that all its origins are fetched with
+%BOOTSTRAP-GUILE."
+ (define rewritten-input
+ (match-lambda
+ ((name (? origin? o))
+ `(,name ,(bootstrap-origin o)))
+ ((name (? package? p) sub-drvs ...)
+ `(,name ,(package-with-bootstrap-guile p) ,@sub-drvs))
+ (x x)))
+
+ (package (inherit p)
+ (source (match (package-source p)
+ ((? origin? o) (bootstrap-origin o))
+ (s s)))
+ (inputs (map rewritten-input
+ (package-inputs p)))
+ (native-inputs (map rewritten-input
+ (package-native-inputs p)))
+ (propagated-inputs (map rewritten-input
+ (package-propagated-inputs p)))))))
+
(define (default-keyword-arguments args defaults)
"Return ARGS augmented with any keyword/value from DEFAULTS for
keywords not already present in ARGS."
@@ -1456,43 +1496,46 @@ previous value of the keyword argument."
(reverse before)))))))
(define gnu-make-boot0
- (package (inherit gnu-make)
- (name "make-boot0")
- (location (source-properties->location (current-source-location)))
- (arguments `(#:guile ,%bootstrap-guile
- #:implicit-inputs? #f
- #:tests? #f ; cannot run "make check"
- #:phases
- (alist-replace
- 'build (lambda _
- (zero? (system* "./build.sh")))
+ (package-with-bootstrap-guile
+ (package (inherit gnu-make)
+ (name "make-boot0")
+ (location (source-properties->location (current-source-location)))
+ (arguments `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ #:tests? #f ; cannot run "make check"
+ #:phases
(alist-replace
- 'install (lambda* (#:key outputs #:allow-other-keys)
- (let* ((out (assoc-ref outputs "out"))
- (bin (string-append out "/bin")))
- (mkdir-p bin)
- (copy-file "make"
- (string-append bin "/make"))))
- %standard-phases))))
- (inputs %bootstrap-inputs)))
+ 'build (lambda _
+ (zero? (system* "./build.sh")))
+ (alist-replace
+ 'install (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (bin (string-append out "/bin")))
+ (mkdir-p bin)
+ (copy-file "make"
+ (string-append bin "/make"))))
+ %standard-phases))))
+ (inputs %bootstrap-inputs))))
(define diffutils-boot0
- (let ((p (package-with-explicit-inputs diffutils
- `(("make" ,gnu-make-boot0)
- ,@%bootstrap-inputs)
- #:guile %bootstrap-guile)))
- (package (inherit p)
- (location (source-properties->location (current-source-location)))
- (arguments `(#:tests? #f ; the test suite needs diffutils
- ,@(package-arguments p))))))
+ (package-with-bootstrap-guile
+ (let ((p (package-with-explicit-inputs diffutils
+ `(("make" ,gnu-make-boot0)
+ ,@%bootstrap-inputs)
+ #:guile %bootstrap-guile)))
+ (package (inherit p)
+ (location (source-properties->location (current-source-location)))
+ (arguments `(#:tests? #f ; the test suite needs diffutils
+ ,@(package-arguments p)))))))
(define findutils-boot0
- (package-with-explicit-inputs findutils
- `(("make" ,gnu-make-boot0)
- ("diffutils" ,diffutils-boot0) ; for tests
- ,@%bootstrap-inputs)
- (current-source-location)
- #:guile %bootstrap-guile))
+ (package-with-bootstrap-guile
+ (package-with-explicit-inputs findutils
+ `(("make" ,gnu-make-boot0)
+ ("diffutils" ,diffutils-boot0) ; for tests
+ ,@%bootstrap-inputs)
+ (current-source-location)
+ #:guile %bootstrap-guile)))
(define %boot0-inputs
@@ -1524,120 +1567,123 @@ identifier SYSTEM."
;; GCC-BOOT0 (below) is built without any reference to the target libc.
(define binutils-boot0
- (package (inherit binutils)
- (name "binutils-cross-boot0")
- (arguments
- (lambda (system)
- `(#:guile ,%bootstrap-guile
- #:implicit-inputs? #f
- ,@(substitute-keyword-arguments (package-arguments binutils)
- ((#:configure-flags cf)
- `(list ,(string-append "--target=" (boot-triplet system))))))))
- (inputs %boot0-inputs)))
+ (package-with-bootstrap-guile
+ (package (inherit binutils)
+ (name "binutils-cross-boot0")
+ (arguments
+ (lambda (system)
+ `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ ,@(substitute-keyword-arguments (package-arguments binutils)
+ ((#:configure-flags cf)
+ `(list ,(string-append "--target=" (boot-triplet system))))))))
+ (inputs %boot0-inputs))))
(define gcc-boot0
- (package (inherit gcc-4.7)
- (name "gcc-cross-boot0")
- (arguments
- (lambda (system)
- `(#:guile ,%bootstrap-guile
- #:implicit-inputs? #f
- #:modules ((guix build gnu-build-system)
- (guix build utils)
- (ice-9 regex)
- (srfi srfi-1)
- (srfi srfi-26))
- ,@(substitute-keyword-arguments ((package-arguments gcc-4.7) system)
- ((#:configure-flags flags)
- `(append (list ,(string-append "--target="
- (boot-triplet system))
-
- ;; No libc yet.
- "--without-headers"
-
- ;; Disable features not needed at this stage.
- "--disable-shared"
- "--enable-languages=c"
- "--disable-libmudflap"
- "--disable-libgomp"
- "--disable-libssp"
- "--disable-libquadmath"
- "--disable-decimal-float")
- (remove (cut string-match "--enable-languages.*" <>)
- ,flags)))
- ((#:phases phases)
- `(alist-cons-after
- 'unpack 'unpack-gmp&co
- (lambda* (#:key inputs #:allow-other-keys)
- (let ((gmp (assoc-ref %build-inputs "gmp-source"))
- (mpfr (assoc-ref %build-inputs "mpfr-source"))
- (mpc (assoc-ref %build-inputs "mpc-source")))
-
- ;; To reduce the set of pre-built bootstrap inputs, build
- ;; GMP & co. from GCC.
- (for-each (lambda (source)
- (or (zero? (system* "tar" "xvf" source))
- (error "failed to unpack tarball"
- source)))
- (list gmp mpfr mpc))
-
- ;; Create symlinks like `gmp' -> `gmp-5.0.5'.
- ,@(map (lambda (lib)
- `(symlink ,(package-full-name lib)
- ,(package-name lib)))
- (list gmp mpfr mpc))
-
- ;; MPFR headers/lib are found under $(MPFR)/src, but
- ;; `configure' wrongfully tells MPC too look under
- ;; $(MPFR), so fix that.
- (substitute* "configure"
- (("extra_mpc_mpfr_configure_flags(.+)--with-mpfr-include=([^/]+)/mpfr(.*)--with-mpfr-lib=([^ ]+)/mpfr"
- _ equals include middle lib)
- (string-append "extra_mpc_mpfr_configure_flags" equals
- "--with-mpfr-include=" include
- "/mpfr/src" middle
- "--with-mpfr-lib=" lib
- "/mpfr/src"))
- (("gmpinc='-I([^ ]+)/mpfr -I([^ ]+)/mpfr" _ a b)
- (string-append "gmpinc='-I" a "/mpfr/src "
- "-I" b "/mpfr/src"))
- (("gmplibs='-L([^ ]+)/mpfr" _ a)
- (string-append "gmplibs='-L" a "/mpfr/src")))))
- (alist-cons-after
- 'install 'symlink-libgcc_eh
- (lambda* (#:key outputs #:allow-other-keys)
- (let ((out (assoc-ref outputs "out")))
- ;; Glibc wants to link against libgcc_eh, so provide
- ;; it.
- (with-directory-excursion
- (string-append out "/lib/gcc/"
- ,(boot-triplet system)
- "/" ,(package-version gcc-4.7))
- (symlink "libgcc.a" "libgcc_eh.a"))))
- ,phases)))))))
-
- (inputs `(("gmp-source" ,(package-source gmp))
- ("mpfr-source" ,(package-source mpfr))
- ("mpc-source" ,(package-source mpc))
- ("binutils-cross" ,binutils-boot0)
-
- ;; Call it differently so that the builder can check whether
- ;; the "libc" input is #f.
- ("libc-native" ,@(assoc-ref %boot0-inputs "libc"))
- ,@(alist-delete "libc" %boot0-inputs)))))
+ (package-with-bootstrap-guile
+ (package (inherit gcc-4.7)
+ (name "gcc-cross-boot0")
+ (arguments
+ (lambda (system)
+ `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ #:modules ((guix build gnu-build-system)
+ (guix build utils)
+ (ice-9 regex)
+ (srfi srfi-1)
+ (srfi srfi-26))
+ ,@(substitute-keyword-arguments ((package-arguments gcc-4.7) system)
+ ((#:configure-flags flags)
+ `(append (list ,(string-append "--target="
+ (boot-triplet system))
+
+ ;; No libc yet.
+ "--without-headers"
+
+ ;; Disable features not needed at this stage.
+ "--disable-shared"
+ "--enable-languages=c"
+ "--disable-libmudflap"
+ "--disable-libgomp"
+ "--disable-libssp"
+ "--disable-libquadmath"
+ "--disable-decimal-float")
+ (remove (cut string-match "--enable-languages.*" <>)
+ ,flags)))
+ ((#:phases phases)
+ `(alist-cons-after
+ 'unpack 'unpack-gmp&co
+ (lambda* (#:key inputs #:allow-other-keys)
+ (let ((gmp (assoc-ref %build-inputs "gmp-source"))
+ (mpfr (assoc-ref %build-inputs "mpfr-source"))
+ (mpc (assoc-ref %build-inputs "mpc-source")))
+
+ ;; To reduce the set of pre-built bootstrap inputs, build
+ ;; GMP & co. from GCC.
+ (for-each (lambda (source)
+ (or (zero? (system* "tar" "xvf" source))
+ (error "failed to unpack tarball"
+ source)))
+ (list gmp mpfr mpc))
+
+ ;; Create symlinks like `gmp' -> `gmp-5.0.5'.
+ ,@(map (lambda (lib)
+ `(symlink ,(package-full-name lib)
+ ,(package-name lib)))
+ (list gmp mpfr mpc))
+
+ ;; MPFR headers/lib are found under $(MPFR)/src, but
+ ;; `configure' wrongfully tells MPC too look under
+ ;; $(MPFR), so fix that.
+ (substitute* "configure"
+ (("extra_mpc_mpfr_configure_flags(.+)--with-mpfr-include=([^/]+)/mpfr(.*)--with-mpfr-lib=([^ ]+)/mpfr"
+ _ equals include middle lib)
+ (string-append "extra_mpc_mpfr_configure_flags" equals
+ "--with-mpfr-include=" include
+ "/mpfr/src" middle
+ "--with-mpfr-lib=" lib
+ "/mpfr/src"))
+ (("gmpinc='-I([^ ]+)/mpfr -I([^ ]+)/mpfr" _ a b)
+ (string-append "gmpinc='-I" a "/mpfr/src "
+ "-I" b "/mpfr/src"))
+ (("gmplibs='-L([^ ]+)/mpfr" _ a)
+ (string-append "gmplibs='-L" a "/mpfr/src")))))
+ (alist-cons-after
+ 'install 'symlink-libgcc_eh
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let ((out (assoc-ref outputs "out")))
+ ;; Glibc wants to link against libgcc_eh, so provide
+ ;; it.
+ (with-directory-excursion
+ (string-append out "/lib/gcc/"
+ ,(boot-triplet system)
+ "/" ,(package-version gcc-4.7))
+ (symlink "libgcc.a" "libgcc_eh.a"))))
+ ,phases)))))))
+
+ (inputs `(("gmp-source" ,(package-source gmp))
+ ("mpfr-source" ,(package-source mpfr))
+ ("mpc-source" ,(package-source mpc))
+ ("binutils-cross" ,binutils-boot0)
+
+ ;; Call it differently so that the builder can check whether
+ ;; the "libc" input is #f.
+ ("libc-native" ,@(assoc-ref %boot0-inputs "libc"))
+ ,@(alist-delete "libc" %boot0-inputs))))))
(define linux-libre-headers-boot0
- (package (inherit linux-libre-headers)
- (arguments `(#:guile ,%bootstrap-guile
- #:implicit-inputs? #f
- ,@(package-arguments linux-libre-headers)))
- (native-inputs
- (let ((perl (package-with-explicit-inputs perl
- %boot0-inputs
- (current-source-location)
- #:guile %bootstrap-guile)))
- `(("perl" ,perl)
- ,@%boot0-inputs)))))
+ (package-with-bootstrap-guile
+ (package (inherit linux-libre-headers)
+ (arguments `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ ,@(package-arguments linux-libre-headers)))
+ (native-inputs
+ (let ((perl (package-with-explicit-inputs perl
+ %boot0-inputs
+ (current-source-location)
+ #:guile %bootstrap-guile)))
+ `(("perl" ,perl)
+ ,@%boot0-inputs))))))
(define %boot1-inputs
;; 2nd stage inputs.
@@ -1651,38 +1697,40 @@ identifier SYSTEM."
(define-public glibc-final
;; The final libc, "cross-built". If everything went well, the resulting
;; store path has no dependencies.
- (package (inherit glibc)
- (arguments
- (lambda (system)
- `(#:guile ,%bootstrap-guile
- #:implicit-inputs? #f
-
- ;; Leave /bin/sh as the interpreter for `ldd', `sotruss', etc. to
- ;; avoid keeping a reference to the bootstrap Bash.
- #:patch-shebangs? #f
- ,@(substitute-keyword-arguments (package-arguments glibc)
- ((#:configure-flags flags)
- `(append (list ,(string-append "--host=" (boot-triplet system))
- ,(string-append "--build="
- (nix-system->gnu-triplet system))
- "BASH_SHELL=/bin/sh"
-
- ;; cross-rpcgen fails to build, because it gets
- ;; built with the cross-compiler instead of the
- ;; native compiler. See also
- ;; <http://sourceware.org/ml/libc-alpha/2012-03/msg00325.html>.
- "--disable-obsolete-rpc")
- ,flags))))))
- (propagated-inputs `(("linux-headers" ,linux-libre-headers-boot0)))
- (inputs `(;; A native GCC is needed to build `cross-rpcgen'.
- ("native-gcc" ,@(assoc-ref %boot0-inputs "gcc"))
- ,@%boot1-inputs))))
+ (package-with-bootstrap-guile
+ (package (inherit glibc)
+ (arguments
+ (lambda (system)
+ `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+
+ ;; Leave /bin/sh as the interpreter for `ldd', `sotruss', etc. to
+ ;; avoid keeping a reference to the bootstrap Bash.
+ #:patch-shebangs? #f
+ ,@(substitute-keyword-arguments (package-arguments glibc)
+ ((#:configure-flags flags)
+ `(append (list ,(string-append "--host=" (boot-triplet system))
+ ,(string-append "--build="
+ (nix-system->gnu-triplet system))
+ "BASH_SHELL=/bin/sh"
+
+ ;; cross-rpcgen fails to build, because it gets
+ ;; built with the cross-compiler instead of the
+ ;; native compiler. See also
+ ;; <http://sourceware.org/ml/libc-alpha/2012-03/msg00325.html>.
+ "--disable-obsolete-rpc")
+ ,flags))))))
+ (propagated-inputs `(("linux-headers" ,linux-libre-headers-boot0)))
+ (inputs `( ;; A native GCC is needed to build `cross-rpcgen'.
+ ("native-gcc" ,@(assoc-ref %boot0-inputs "gcc"))
+ ,@%boot1-inputs)))))
(define gcc-boot0-wrapped
;; Make the cross-tools GCC-BOOT0 and BINUTILS-BOOT0 available under the
;; non-cross names.
(package (inherit gcc-4.7)
(name (string-append (package-name gcc-boot0) "-wrapped"))
+ (source #f)
(build-system trivial-build-system)
(arguments
(lambda (system)
@@ -1821,16 +1869,18 @@ store.")
,@(alist-delete "gcc" %boot2-inputs)))
(define-public bash-final
- (package-with-explicit-inputs bash %boot3-inputs
- (current-source-location)
- #:guile %bootstrap-guile))
+ (package-with-bootstrap-guile
+ (package-with-explicit-inputs bash %boot3-inputs
+ (current-source-location)
+ #:guile %bootstrap-guile)))
(define-public guile-final
- (package-with-explicit-inputs guile-2.0
- `(("bash" ,bash-final)
- ,@(alist-delete "bash" %boot3-inputs))
- (current-source-location)
- #:guile %bootstrap-guile))
+ (package-with-bootstrap-guile
+ (package-with-explicit-inputs guile-2.0
+ `(("bash" ,bash-final)
+ ,@(alist-delete "bash" %boot3-inputs))
+ (current-source-location)
+ #:guile %bootstrap-guile)))
(define-public ld-wrapper
;; The final `ld' wrapper, which uses the final Guile.
diff --git a/guix/ftp.scm b/guix/ftp.scm
index 79bae6ece6..2717bf3fb3 100644
--- a/guix/ftp.scm
+++ b/guix/ftp.scm
@@ -17,7 +17,10 @@
;;; along with Guix. If not, see <ftp://www.gnu.org/licenses/>.
(define-module (guix ftp)
+ #:use-module (ice-9 match)
#:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module ((guix store) #:select (derivation-path?))
#:use-module (guix utils)
#:export (ftp-fetch))
@@ -29,7 +32,7 @@
(define* (ftp-fetch store url hash-algo hash
#:optional name
- #:key (system (%current-system)))
+ #:key (system (%current-system)) guile)
"Return the path of a fixed-output derivation in STORE that fetches URL,
which is expected to have hash HASH of type HASH-ALGO (a symbol). By
default, the file name is the base name of URL; optionally, NAME can specify
@@ -39,11 +42,24 @@ a different file name."
(use-modules (guix build ftp))
(ftp-fetch ,url %output)))
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system))
+ ((and (? string?) (? derivation-path?))
+ guile)
+ (#f ; the default
+ (let* ((distro (resolve-interface '(distro packages base)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system)))))
+
(build-expression->derivation store (or name (basename url)) system
builder '()
#:hash-algo hash-algo
#:hash hash
#:modules '((guix ftp-client)
(guix build ftp)
- (guix build utils))))
+ (guix build utils))
+ #:guile-for-build guile-for-build))
+
;;; ftp.scm ends here
diff --git a/guix/http.scm b/guix/http.scm
index 97ed3983f1..182d011b77 100644
--- a/guix/http.scm
+++ b/guix/http.scm
@@ -17,7 +17,10 @@
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix http)
+ #:use-module (ice-9 match)
#:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module ((guix store) #:select (derivation-path?))
#:use-module (guix utils)
#:export (http-fetch))
@@ -29,7 +32,7 @@
(define* (http-fetch store url hash-algo hash
#:optional name
- #:key (system (%current-system)))
+ #:key (system (%current-system)) guile)
"Return the path of a fixed-output derivation in STORE that fetches URL,
which is expected to have hash HASH of type HASH-ALGO (a symbol). By
default, the file name is the base name of URL; optionally, NAME can specify
@@ -39,8 +42,22 @@ a different file name."
(use-modules (guix build http))
(http-fetch ,url %output)))
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system))
+ ((and (? string?) (? derivation-path?))
+ guile)
+ (#f ; the default
+ (let* ((distro (resolve-interface '(distro packages base)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system)))))
+
(build-expression->derivation store (or name (basename url)) system
builder '()
#:hash-algo hash-algo
#:hash hash
- #:modules '((guix build http))))
+ #:modules '((guix build http))
+ #:guile-for-build guile-for-build))
+
+;;; http.scm ends here