nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2012-10-17 23:55:38 +02:00
parent d14ecda913
commit d6e8777688
3 changed files with 254 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

384
distro/packages/base.scm
View File

@ -1424,6 +1424,46 @@ $out/bin/guile --version~%"
(home-page #f) (home-page #f)
(license "LGPLv3+")))) (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) (define (default-keyword-arguments args defaults)
"Return ARGS augmented with any keyword/value from DEFAULTS for "Return ARGS augmented with any keyword/value from DEFAULTS for
keywords not already present in ARGS." keywords not already present in ARGS."
@ -1456,43 +1496,46 @@ previous value of the keyword argument."
(reverse before))))))) (reverse before)))))))
(define gnu-make-boot0 (define gnu-make-boot0
(package (inherit gnu-make) (package-with-bootstrap-guile
(name "make-boot0") (package (inherit gnu-make)
(location (source-properties->location (current-source-location))) (name "make-boot0")
(arguments `(#:guile ,%bootstrap-guile (location (source-properties->location (current-source-location)))
#:implicit-inputs? #f (arguments `(#:guile ,%bootstrap-guile
#:tests? #f ; cannot run "make check" #:implicit-inputs? #f
#:phases #:tests? #f ; cannot run "make check"
(alist-replace #:phases
'build (lambda _
(zero? (system* "./build.sh")))
(alist-replace (alist-replace
'install (lambda* (#:key outputs #:allow-other-keys) 'build (lambda _
(let* ((out (assoc-ref outputs "out")) (zero? (system* "./build.sh")))
(bin (string-append out "/bin"))) (alist-replace
(mkdir-p bin) 'install (lambda* (#:key outputs #:allow-other-keys)
(copy-file "make" (let* ((out (assoc-ref outputs "out"))
(string-append bin "/make")))) (bin (string-append out "/bin")))
%standard-phases)))) (mkdir-p bin)
(inputs %bootstrap-inputs))) (copy-file "make"
(string-append bin "/make"))))
%standard-phases))))
(inputs %bootstrap-inputs))))
(define diffutils-boot0 (define diffutils-boot0
(let ((p (package-with-explicit-inputs diffutils (package-with-bootstrap-guile
`(("make" ,gnu-make-boot0) (let ((p (package-with-explicit-inputs diffutils
,@%bootstrap-inputs) `(("make" ,gnu-make-boot0)
#:guile %bootstrap-guile))) ,@%bootstrap-inputs)
(package (inherit p) #:guile %bootstrap-guile)))
(location (source-properties->location (current-source-location))) (package (inherit p)
(arguments `(#:tests? #f ; the test suite needs diffutils (location (source-properties->location (current-source-location)))
,@(package-arguments p)))))) (arguments `(#:tests? #f ; the test suite needs diffutils
,@(package-arguments p)))))))
(define findutils-boot0 (define findutils-boot0
(package-with-explicit-inputs findutils (package-with-bootstrap-guile
`(("make" ,gnu-make-boot0) (package-with-explicit-inputs findutils
("diffutils" ,diffutils-boot0) ; for tests `(("make" ,gnu-make-boot0)
,@%bootstrap-inputs) ("diffutils" ,diffutils-boot0) ; for tests
(current-source-location) ,@%bootstrap-inputs)
#:guile %bootstrap-guile)) (current-source-location)
#:guile %bootstrap-guile)))
(define %boot0-inputs (define %boot0-inputs
@ -1524,120 +1567,123 @@ identifier SYSTEM."
;; GCC-BOOT0 (below) is built without any reference to the target libc. ;; GCC-BOOT0 (below) is built without any reference to the target libc.
(define binutils-boot0 (define binutils-boot0
(package (inherit binutils) (package-with-bootstrap-guile
(name "binutils-cross-boot0") (package (inherit binutils)
(arguments (name "binutils-cross-boot0")
(lambda (system) (arguments
`(#:guile ,%bootstrap-guile (lambda (system)
#:implicit-inputs? #f `(#:guile ,%bootstrap-guile
,@(substitute-keyword-arguments (package-arguments binutils) #:implicit-inputs? #f
((#:configure-flags cf) ,@(substitute-keyword-arguments (package-arguments binutils)
`(list ,(string-append "--target=" (boot-triplet system)))))))) ((#:configure-flags cf)
(inputs %boot0-inputs))) `(list ,(string-append "--target=" (boot-triplet system))))))))
(inputs %boot0-inputs))))
(define gcc-boot0 (define gcc-boot0
(package (inherit gcc-4.7) (package-with-bootstrap-guile
(name "gcc-cross-boot0") (package (inherit gcc-4.7)
(arguments (name "gcc-cross-boot0")
(lambda (system) (arguments
`(#:guile ,%bootstrap-guile (lambda (system)
#:implicit-inputs? #f `(#:guile ,%bootstrap-guile
#:modules ((guix build gnu-build-system) #:implicit-inputs? #f
(guix build utils) #:modules ((guix build gnu-build-system)
(ice-9 regex) (guix build utils)
(srfi srfi-1) (ice-9 regex)
(srfi srfi-26)) (srfi srfi-1)
,@(substitute-keyword-arguments ((package-arguments gcc-4.7) system) (srfi srfi-26))
((#:configure-flags flags) ,@(substitute-keyword-arguments ((package-arguments gcc-4.7) system)
`(append (list ,(string-append "--target=" ((#:configure-flags flags)
(boot-triplet system)) `(append (list ,(string-append "--target="
(boot-triplet system))
;; No libc yet. ;; No libc yet.
"--without-headers" "--without-headers"
;; Disable features not needed at this stage. ;; Disable features not needed at this stage.
"--disable-shared" "--disable-shared"
"--enable-languages=c" "--enable-languages=c"
"--disable-libmudflap" "--disable-libmudflap"
"--disable-libgomp" "--disable-libgomp"
"--disable-libssp" "--disable-libssp"
"--disable-libquadmath" "--disable-libquadmath"
"--disable-decimal-float") "--disable-decimal-float")
(remove (cut string-match "--enable-languages.*" <>) (remove (cut string-match "--enable-languages.*" <>)
,flags))) ,flags)))
((#:phases phases) ((#:phases phases)
`(alist-cons-after `(alist-cons-after
'unpack 'unpack-gmp&co 'unpack 'unpack-gmp&co
(lambda* (#:key inputs #:allow-other-keys) (lambda* (#:key inputs #:allow-other-keys)
(let ((gmp (assoc-ref %build-inputs "gmp-source")) (let ((gmp (assoc-ref %build-inputs "gmp-source"))
(mpfr (assoc-ref %build-inputs "mpfr-source")) (mpfr (assoc-ref %build-inputs "mpfr-source"))
(mpc (assoc-ref %build-inputs "mpc-source"))) (mpc (assoc-ref %build-inputs "mpc-source")))
;; To reduce the set of pre-built bootstrap inputs, build ;; To reduce the set of pre-built bootstrap inputs, build
;; GMP & co. from GCC. ;; GMP & co. from GCC.
(for-each (lambda (source) (for-each (lambda (source)
(or (zero? (system* "tar" "xvf" source)) (or (zero? (system* "tar" "xvf" source))
(error "failed to unpack tarball" (error "failed to unpack tarball"
source))) source)))
(list gmp mpfr mpc)) (list gmp mpfr mpc))
;; Create symlinks like `gmp' -> `gmp-5.0.5'. ;; Create symlinks like `gmp' -> `gmp-5.0.5'.
,@(map (lambda (lib) ,@(map (lambda (lib)
`(symlink ,(package-full-name lib) `(symlink ,(package-full-name lib)
,(package-name lib))) ,(package-name lib)))
(list gmp mpfr mpc)) (list gmp mpfr mpc))
;; MPFR headers/lib are found under $(MPFR)/src, but ;; MPFR headers/lib are found under $(MPFR)/src, but
;; `configure' wrongfully tells MPC too look under ;; `configure' wrongfully tells MPC too look under
;; $(MPFR), so fix that. ;; $(MPFR), so fix that.
(substitute* "configure" (substitute* "configure"
(("extra_mpc_mpfr_configure_flags(.+)--with-mpfr-include=([^/]+)/mpfr(.*)--with-mpfr-lib=([^ ]+)/mpfr" (("extra_mpc_mpfr_configure_flags(.+)--with-mpfr-include=([^/]+)/mpfr(.*)--with-mpfr-lib=([^ ]+)/mpfr"
_ equals include middle lib) _ equals include middle lib)
(string-append "extra_mpc_mpfr_configure_flags" equals (string-append "extra_mpc_mpfr_configure_flags" equals
"--with-mpfr-include=" include "--with-mpfr-include=" include
"/mpfr/src" middle "/mpfr/src" middle
"--with-mpfr-lib=" lib "--with-mpfr-lib=" lib
"/mpfr/src")) "/mpfr/src"))
(("gmpinc='-I([^ ]+)/mpfr -I([^ ]+)/mpfr" _ a b) (("gmpinc='-I([^ ]+)/mpfr -I([^ ]+)/mpfr" _ a b)
(string-append "gmpinc='-I" a "/mpfr/src " (string-append "gmpinc='-I" a "/mpfr/src "
"-I" b "/mpfr/src")) "-I" b "/mpfr/src"))
(("gmplibs='-L([^ ]+)/mpfr" _ a) (("gmplibs='-L([^ ]+)/mpfr" _ a)
(string-append "gmplibs='-L" a "/mpfr/src"))))) (string-append "gmplibs='-L" a "/mpfr/src")))))
(alist-cons-after (alist-cons-after
'install 'symlink-libgcc_eh 'install 'symlink-libgcc_eh
(lambda* (#:key outputs #:allow-other-keys) (lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))) (let ((out (assoc-ref outputs "out")))
;; Glibc wants to link against libgcc_eh, so provide ;; Glibc wants to link against libgcc_eh, so provide
;; it. ;; it.
(with-directory-excursion (with-directory-excursion
(string-append out "/lib/gcc/" (string-append out "/lib/gcc/"
,(boot-triplet system) ,(boot-triplet system)
"/" ,(package-version gcc-4.7)) "/" ,(package-version gcc-4.7))
(symlink "libgcc.a" "libgcc_eh.a")))) (symlink "libgcc.a" "libgcc_eh.a"))))
,phases))))))) ,phases)))))))
(inputs `(("gmp-source" ,(package-source gmp)) (inputs `(("gmp-source" ,(package-source gmp))
("mpfr-source" ,(package-source mpfr)) ("mpfr-source" ,(package-source mpfr))
("mpc-source" ,(package-source mpc)) ("mpc-source" ,(package-source mpc))
("binutils-cross" ,binutils-boot0) ("binutils-cross" ,binutils-boot0)
;; Call it differently so that the builder can check whether ;; Call it differently so that the builder can check whether
;; the "libc" input is #f. ;; the "libc" input is #f.
("libc-native" ,@(assoc-ref %boot0-inputs "libc")) ("libc-native" ,@(assoc-ref %boot0-inputs "libc"))
,@(alist-delete "libc" %boot0-inputs))))) ,@(alist-delete "libc" %boot0-inputs))))))
(define linux-libre-headers-boot0 (define linux-libre-headers-boot0
(package (inherit linux-libre-headers) (package-with-bootstrap-guile
(arguments `(#:guile ,%bootstrap-guile (package (inherit linux-libre-headers)
#:implicit-inputs? #f (arguments `(#:guile ,%bootstrap-guile
,@(package-arguments linux-libre-headers))) #:implicit-inputs? #f
(native-inputs ,@(package-arguments linux-libre-headers)))
(let ((perl (package-with-explicit-inputs perl (native-inputs
%boot0-inputs (let ((perl (package-with-explicit-inputs perl
(current-source-location) %boot0-inputs
#:guile %bootstrap-guile))) (current-source-location)
`(("perl" ,perl) #:guile %bootstrap-guile)))
,@%boot0-inputs))))) `(("perl" ,perl)
,@%boot0-inputs))))))
(define %boot1-inputs (define %boot1-inputs
;; 2nd stage inputs. ;; 2nd stage inputs.
@ -1651,38 +1697,40 @@ identifier SYSTEM."
(define-public glibc-final (define-public glibc-final
;; The final libc, "cross-built". If everything went well, the resulting ;; The final libc, "cross-built". If everything went well, the resulting
;; store path has no dependencies. ;; store path has no dependencies.
(package (inherit glibc) (package-with-bootstrap-guile
(arguments (package (inherit glibc)
(lambda (system) (arguments
`(#:guile ,%bootstrap-guile (lambda (system)
#:implicit-inputs? #f `(#:guile ,%bootstrap-guile
#:implicit-inputs? #f
;; Leave /bin/sh as the interpreter for `ldd', `sotruss', etc. to ;; Leave /bin/sh as the interpreter for `ldd', `sotruss', etc. to
;; avoid keeping a reference to the bootstrap Bash. ;; avoid keeping a reference to the bootstrap Bash.
#:patch-shebangs? #f #:patch-shebangs? #f
,@(substitute-keyword-arguments (package-arguments glibc) ,@(substitute-keyword-arguments (package-arguments glibc)
((#:configure-flags flags) ((#:configure-flags flags)
`(append (list ,(string-append "--host=" (boot-triplet system)) `(append (list ,(string-append "--host=" (boot-triplet system))
,(string-append "--build=" ,(string-append "--build="
(nix-system->gnu-triplet system)) (nix-system->gnu-triplet system))
"BASH_SHELL=/bin/sh" "BASH_SHELL=/bin/sh"
;; cross-rpcgen fails to build, because it gets ;; cross-rpcgen fails to build, because it gets
;; built with the cross-compiler instead of the ;; built with the cross-compiler instead of the
;; native compiler. See also ;; native compiler. See also
;; <http://sourceware.org/ml/libc-alpha/2012-03/msg00325.html>. ;; <http://sourceware.org/ml/libc-alpha/2012-03/msg00325.html>.
"--disable-obsolete-rpc") "--disable-obsolete-rpc")
,flags)))))) ,flags))))))
(propagated-inputs `(("linux-headers" ,linux-libre-headers-boot0))) (propagated-inputs `(("linux-headers" ,linux-libre-headers-boot0)))
(inputs `(;; A native GCC is needed to build `cross-rpcgen'. (inputs `( ;; A native GCC is needed to build `cross-rpcgen'.
("native-gcc" ,@(assoc-ref %boot0-inputs "gcc")) ("native-gcc" ,@(assoc-ref %boot0-inputs "gcc"))
,@%boot1-inputs)))) ,@%boot1-inputs)))))
(define gcc-boot0-wrapped (define gcc-boot0-wrapped
;; Make the cross-tools GCC-BOOT0 and BINUTILS-BOOT0 available under the ;; Make the cross-tools GCC-BOOT0 and BINUTILS-BOOT0 available under the
;; non-cross names. ;; non-cross names.
(package (inherit gcc-4.7) (package (inherit gcc-4.7)
(name (string-append (package-name gcc-boot0) "-wrapped")) (name (string-append (package-name gcc-boot0) "-wrapped"))
(source #f)
(build-system trivial-build-system) (build-system trivial-build-system)
(arguments (arguments
(lambda (system) (lambda (system)
@ -1821,16 +1869,18 @@ store.")
,@(alist-delete "gcc" %boot2-inputs))) ,@(alist-delete "gcc" %boot2-inputs)))
(define-public bash-final (define-public bash-final
(package-with-explicit-inputs bash %boot3-inputs (package-with-bootstrap-guile
(current-source-location) (package-with-explicit-inputs bash %boot3-inputs
#:guile %bootstrap-guile)) (current-source-location)
#:guile %bootstrap-guile)))
(define-public guile-final (define-public guile-final
(package-with-explicit-inputs guile-2.0 (package-with-bootstrap-guile
`(("bash" ,bash-final) (package-with-explicit-inputs guile-2.0
,@(alist-delete "bash" %boot3-inputs)) `(("bash" ,bash-final)
(current-source-location) ,@(alist-delete "bash" %boot3-inputs))
#:guile %bootstrap-guile)) (current-source-location)
#:guile %bootstrap-guile)))
(define-public ld-wrapper (define-public ld-wrapper
;; The final `ld' wrapper, which uses the final Guile. ;; The final `ld' wrapper, which uses the final Guile.

20
guix/ftp.scm
View File

@ -17,7 +17,10 @@
;;; along with Guix. If not, see <ftp://www.gnu.org/licenses/>. ;;; along with Guix. If not, see <ftp://www.gnu.org/licenses/>.
(define-module (guix ftp) (define-module (guix ftp)
#:use-module (ice-9 match)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages)
#:use-module ((guix store) #:select (derivation-path?))
#:use-module (guix utils) #:use-module (guix utils)
#:export (ftp-fetch)) #:export (ftp-fetch))
@ -29,7 +32,7 @@
(define* (ftp-fetch store url hash-algo hash (define* (ftp-fetch store url hash-algo hash
#:optional name #:optional name
#:key (system (%current-system))) #:key (system (%current-system)) guile)
"Return the path of a fixed-output derivation in STORE that fetches URL, "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 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 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)) (use-modules (guix build ftp))
(ftp-fetch ,url %output))) (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 (build-expression->derivation store (or name (basename url)) system
builder '() builder '()
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:modules '((guix ftp-client) #:modules '((guix ftp-client)
(guix build ftp) (guix build ftp)
(guix build utils)))) (guix build utils))
#:guile-for-build guile-for-build))
;;; ftp.scm ends here ;;; ftp.scm ends here

21
guix/http.scm
View File

@ -17,7 +17,10 @@
;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix http) (define-module (guix http)
#:use-module (ice-9 match)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages)
#:use-module ((guix store) #:select (derivation-path?))
#:use-module (guix utils) #:use-module (guix utils)
#:export (http-fetch)) #:export (http-fetch))
@ -29,7 +32,7 @@
(define* (http-fetch store url hash-algo hash (define* (http-fetch store url hash-algo hash
#:optional name #:optional name
#:key (system (%current-system))) #:key (system (%current-system)) guile)
"Return the path of a fixed-output derivation in STORE that fetches URL, "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 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 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)) (use-modules (guix build http))
(http-fetch ,url %output))) (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 (build-expression->derivation store (or name (basename url)) system
builder '() builder '()
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:modules '((guix build http)))) #:modules '((guix build http))
#:guile-for-build guile-for-build))
;;; http.scm ends here