Browse Source

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.
version-0.8.3
Ludovic Courtès 10 years ago
parent
commit
d6e8777688
  1. 402
      distro/packages/base.scm
  2. 20
      guix/ftp.scm
  3. 21
      guix/http.scm

402
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.

20
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

21
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

Loading…
Cancel
Save