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

70
distro/packages/base.scm
View File

@ -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,6 +1496,7 @@ previous value of the keyword argument."
(reverse before)))))))
(define gnu-make-boot0
(package-with-bootstrap-guile
(package (inherit gnu-make)
(name "make-boot0")
(location (source-properties->location (current-source-location)))
@ -1474,9 +1515,10 @@ previous value of the keyword argument."
(copy-file "make"
(string-append bin "/make"))))
%standard-phases))))
(inputs %bootstrap-inputs)))
(inputs %bootstrap-inputs))))
(define diffutils-boot0
(package-with-bootstrap-guile
(let ((p (package-with-explicit-inputs diffutils
`(("make" ,gnu-make-boot0)
,@%bootstrap-inputs)
@ -1484,15 +1526,16 @@ previous value of the keyword argument."
(package (inherit p)
(location (source-properties->location (current-source-location)))
(arguments `(#:tests? #f ; the test suite needs diffutils
,@(package-arguments p))))))
,@(package-arguments p)))))))
(define findutils-boot0
(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))
#:guile %bootstrap-guile)))
(define %boot0-inputs
@ -1524,6 +1567,7 @@ identifier SYSTEM."
;; GCC-BOOT0 (below) is built without any reference to the target libc.
(define binutils-boot0
(package-with-bootstrap-guile
(package (inherit binutils)
(name "binutils-cross-boot0")
(arguments
@ -1533,9 +1577,10 @@ identifier SYSTEM."
,@(substitute-keyword-arguments (package-arguments binutils)
((#:configure-flags cf)
`(list ,(string-append "--target=" (boot-triplet system))))))))
(inputs %boot0-inputs)))
(inputs %boot0-inputs))))
(define gcc-boot0
(package-with-bootstrap-guile
(package (inherit gcc-4.7)
(name "gcc-cross-boot0")
(arguments
@ -1624,9 +1669,10 @@ identifier SYSTEM."
;; 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)))))
,@(alist-delete "libc" %boot0-inputs))))))
(define linux-libre-headers-boot0
(package-with-bootstrap-guile
(package (inherit linux-libre-headers)
(arguments `(#:guile ,%bootstrap-guile
#:implicit-inputs? #f
@ -1637,7 +1683,7 @@ identifier SYSTEM."
(current-source-location)
#:guile %bootstrap-guile)))
`(("perl" ,perl)
,@%boot0-inputs)))))
,@%boot0-inputs))))))
(define %boot1-inputs
;; 2nd stage inputs.
@ -1651,6 +1697,7 @@ identifier SYSTEM."
(define-public glibc-final
;; The final libc, "cross-built". If everything went well, the resulting
;; store path has no dependencies.
(package-with-bootstrap-guile
(package (inherit glibc)
(arguments
(lambda (system)
@ -1674,15 +1721,16 @@ identifier SYSTEM."
"--disable-obsolete-rpc")
,flags))))))
(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"))
,@%boot1-inputs))))
,@%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-bootstrap-guile
(package-with-explicit-inputs bash %boot3-inputs
(current-source-location)
#:guile %bootstrap-guile))
#:guile %bootstrap-guile)))
(define-public guile-final
(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))
#:guile %bootstrap-guile)))
(define-public ld-wrapper
;; 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/>.
(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
View File

@ -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