build-system/gnu: Unify with (guix build-system gnu-cross-build).

* guix/build/gnu-build-system.scm (set-paths): Add `native-inputs' and
  `native-search-paths' keyword parameters.  Honor them.
  (configure): Add `target' and `native-inputs' keyword parameters.
  Look for Bash in NATIVE-INPUTS or INPUTS.  Pass `--host' when TARGET
  is true.
  (strip): Add `strip-command' keyword parameter.  Use it.
* guix/build/gnu-cross-build.scm: Remove.
* Makefile.am (MODULES): Adjust accordingly.
* gnu/packages/acl.scm, gnu/packages/attr.scm, gnu/packages/base.scm,
  gnu/packages/bash.scm, gnu/packages/gawk.scm,
  gnu/packages/gettext.scm, gnu/packages/guile.scm,
  gnu/packages/libffi.scm, gnu/packages/libsigsegv.scm,
  gnu/packages/linux.scm, gnu/packages/ncurses.scm,
  gnu/packages/readline.scm, guix/build-system/gnu.scm: Replace
  `%standard-cross-phases' by `%standard-phases'.  Remove references
  to (guix build gnu-cross-build).
This commit is contained in:
Ludovic Courtès 2013-06-21 00:25:54 +02:00
parent d501fad11c
commit 56c092ce94
16 changed files with 54 additions and 192 deletions

View file

@ -59,7 +59,6 @@ MODULES = \
guix/build/download.scm \ guix/build/download.scm \
guix/build/cmake-build-system.scm \ guix/build/cmake-build-system.scm \
guix/build/gnu-build-system.scm \ guix/build/gnu-build-system.scm \
guix/build/gnu-cross-build.scm \
guix/build/perl-build-system.scm \ guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \ guix/build/python-build-system.scm \
guix/build/utils.scm \ guix/build/utils.scm \

View file

@ -46,7 +46,7 @@ (define-public acl
(lambda _ (lambda _
(patch-makefile-SHELL "include/buildmacros")) (patch-makefile-SHELL "include/buildmacros"))
,(if (%current-target-system) ,(if (%current-target-system)
'%standard-cross-phases '%standard-phases
'(alist-replace 'check '(alist-replace 'check
(lambda _ (lambda _
(system* "make" "tests" "-C" "test") (system* "make" "tests" "-C" "test")

View file

@ -55,7 +55,7 @@ (define-public attr
;; When building natively, adjust the test cases. ;; When building natively, adjust the test cases.
,(if (%current-target-system) ,(if (%current-target-system)
'%standard-cross-phases '%standard-phases
'(alist-replace 'check '(alist-replace 'check
(lambda _ (lambda _
;; Use the right shell. ;; Use the right shell.

View file

@ -293,9 +293,7 @@ (define-public coreutils
(substitute* (find-files "tests" "\\.sh$") (substitute* (find-files "tests" "\\.sh$")
(("#!/bin/sh") (("#!/bin/sh")
(format #f "#!~a/bin/bash" bash))))) (format #f "#!~a/bin/bash" bash)))))
,(if (%current-target-system) %standard-phases)))
'%standard-cross-phases
'%standard-phases))))
(synopsis "Core GNU utilities (file, text, shell)") (synopsis "Core GNU utilities (file, text, shell)")
(description (description
"The GNU Core Utilities are the basic file, shell and text manipulation "The GNU Core Utilities are the basic file, shell and text manipulation

View file

@ -82,9 +82,7 @@ (define-public bash
#:phases (alist-cons-after 'install 'post-install #:phases (alist-cons-after 'install 'post-install
,post-install-phase ,post-install-phase
,(if (%current-target-system) %standard-phases)))
'%standard-cross-phases
'%standard-phases))))
(synopsis "The GNU Bourne-Again SHell") (synopsis "The GNU Bourne-Again SHell")
(description (description
"Bash is the shell, or command language interpreter, that will appear in "Bash is the shell, or command language interpreter, that will appear in
@ -106,10 +104,7 @@ (define-public bash-light
(let ((args `(#:modules ((guix build gnu-build-system) (let ((args `(#:modules ((guix build gnu-build-system)
(guix build utils) (guix build utils)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26) (srfi srfi-26))
,@(if (%current-target-system)
'((guix build gnu-cross-build))
'()))
,@(package-arguments bash)))) ,@(package-arguments bash))))
(substitute-keyword-arguments args (substitute-keyword-arguments args
((#:configure-flags flags) ((#:configure-flags flags)

View file

@ -50,9 +50,7 @@ (define-public gawk
(substitute* "io.c" (substitute* "io.c"
(("/bin/sh") (("/bin/sh")
(string-append bash "/bin/bash"))))) (string-append bash "/bin/bash")))))
,(if (%current-target-system) %standard-phases)))
'%standard-cross-phases
'%standard-phases))))
(inputs `(("libsigsegv" ,libsigsegv) (inputs `(("libsigsegv" ,libsigsegv)
;; TODO: On next core-updates, make Bash input unconditional. ;; TODO: On next core-updates, make Bash input unconditional.

View file

@ -39,7 +39,7 @@ (define-public gettext
(arguments (arguments
`(#:patches (list (assoc-ref %build-inputs "patch/gets")) `(#:patches (list (assoc-ref %build-inputs "patch/gets"))
#:phases ,(if (%current-target-system) #:phases ,(if (%current-target-system)
'%standard-cross-phases '%standard-phases
'(alist-cons-before '(alist-cons-before
'check 'patch-tests 'check 'patch-tests
(lambda* (#:key inputs #:allow-other-keys) (lambda* (#:key inputs #:allow-other-keys)

View file

@ -158,9 +158,7 @@ (define-public guile-2.0
(substitute* "module/ice-9/popen.scm" (substitute* "module/ice-9/popen.scm"
(("/bin/sh") (("/bin/sh")
(string-append bash "/bin/bash"))))) (string-append bash "/bin/bash")))))
,(if (%current-target-system) %standard-phases)
'%standard-cross-phases
'%standard-phases))
,@(if (%current-target-system) ,@(if (%current-target-system)
'(#:configure-flags '("CC_FOR_BUILD=gcc")) '(#:configure-flags '("CC_FOR_BUILD=gcc"))

View file

@ -49,15 +49,10 @@ (define out (assoc-ref outputs "out"))
"0ln4jbpb6clcsdpb9niqk0frgx4k0xki96wiv067ig0q4cajb7aq")))) "0ln4jbpb6clcsdpb9niqk0frgx4k0xki96wiv067ig0q4cajb7aq"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments `(#:modules ((guix build utils) (guix build gnu-build-system) (arguments `(#:modules ((guix build utils) (guix build gnu-build-system)
(ice-9 ftw) (srfi srfi-26) (ice-9 ftw) (srfi srfi-26))
,@(if (%current-target-system)
'((guix build gnu-cross-build))
'()))
#:phases (alist-cons-after 'install 'post-install #:phases (alist-cons-after 'install 'post-install
,post-install-phase ,post-install-phase
,(if (%current-target-system) %standard-phases)))
'%standard-cross-phases
'%standard-phases))))
(synopsis "Foreign function call interface library") (synopsis "Foreign function call interface library")
(description (description
"The libffi library provides a portable, high level programming interface "The libffi library provides a portable, high level programming interface

View file

@ -49,9 +49,7 @@ (define-public libsigsegv
(lambda _ (lambda _
(substitute* "src/fault-linux-mips-old.h" (substitute* "src/fault-linux-mips-old.h"
(("#include <asm/sigcontext\\.h>") ""))) (("#include <asm/sigcontext\\.h>") "")))
,(if (%current-target-system) %standard-phases))
'%standard-cross-phases
'%standard-phases)))
'())) '()))
(description (description
"GNU libsigsegv is a library for handling page faults in user mode. A page "GNU libsigsegv is a library for handling page faults in user mode. A page

View file

@ -80,18 +80,12 @@ (define-public linux-libre-headers
(arguments (arguments
`(#:modules ((guix build gnu-build-system) `(#:modules ((guix build gnu-build-system)
(guix build utils) (guix build utils)
(srfi srfi-1) (srfi srfi-1))
,@(if (%current-target-system)
'((guix build gnu-cross-build))
'()))
#:phases (alist-replace #:phases (alist-replace
'build ,(build-phase (%current-system)) 'build ,(build-phase (%current-system))
(alist-replace (alist-replace
'install ,install-phase 'install ,install-phase
(alist-delete 'configure (alist-delete 'configure %standard-phases)))
,(if (%current-target-system)
'%standard-cross-phases
'%standard-phases))))
#:tests? #f)) #:tests? #f))
(synopsis "GNU Linux-Libre kernel headers") (synopsis "GNU Linux-Libre kernel headers")
(description "Headers of the Linux-Libre kernel.") (description "Headers of the Linux-Libre kernel.")

View file

@ -116,7 +116,7 @@ (define lib.so
,cross-pre-install-phase ,cross-pre-install-phase
(alist-cons-after (alist-cons-after
'install 'post-install ,post-install-phase 'install 'post-install ,post-install-phase
%standard-cross-phases))) %standard-phases)))
`(alist-cons-after ; native build `(alist-cons-after ; native build
'install 'post-install ,post-install-phase 'install 'post-install ,post-install-phase

View file

@ -61,9 +61,7 @@ (define-public readline
#:phases (alist-cons-after #:phases (alist-cons-after
'install 'post-install 'install 'post-install
,post-install-phase ,post-install-phase
,(if (%current-target-system) %standard-phases)))
'%standard-cross-phases
'%standard-phases))))
(synopsis "Edit command lines while typing, with history support") (synopsis "Edit command lines while typing, with history support")
(description (description
"The GNU Readline library provides a set of functions for use by "The GNU Readline library provides a set of functions for use by

View file

@ -340,14 +340,12 @@ (define* (gnu-cross-build store name target source inputs native-inputs
(strip-flags ''("--strip-debug")) (strip-flags ''("--strip-debug"))
(strip-directories ''("lib" "lib64" "libexec" (strip-directories ''("lib" "lib64" "libexec"
"bin" "sbin")) "bin" "sbin"))
(phases '%standard-cross-phases) (phases '%standard-phases)
(system (%current-system)) (system (%current-system))
(implicit-inputs? #t) ; useful when bootstrapping (implicit-inputs? #t)
(imported-modules '((guix build gnu-build-system) (imported-modules '((guix build gnu-build-system)
(guix build gnu-cross-build)
(guix build utils))) (guix build utils)))
(modules '((guix build gnu-build-system) (modules '((guix build gnu-build-system)
(guix build gnu-cross-build)
(guix build utils)))) (guix build utils))))
"Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are
cross-built inputs, and NATIVE-INPUTS are inputs that run on the build cross-built inputs, and NATIVE-INPUTS are inputs that run on the build

View file

@ -48,15 +48,28 @@ (define (first-subdirectory dir)
#f #f
dir)) dir))
(define* (set-paths #:key inputs (search-paths '()) (define* (set-paths #:key target inputs native-inputs
(search-paths '()) (native-search-paths '())
#:allow-other-keys) #:allow-other-keys)
(define input-directories (define input-directories
(match inputs (match inputs
(((_ . dir) ...) (((_ . dir) ...)
dir))) dir)))
(define native-input-directories
(match native-inputs
(((_ . dir) ...)
dir)
(#f ; not cross compiling
'())))
;; When cross building, $PATH must refer only to native (host) inputs since
;; target inputs are not executable.
(set-path-environment-variable "PATH" '("bin" "sbin") (set-path-environment-variable "PATH" '("bin" "sbin")
input-directories) (append native-input-directories
(if target
'()
input-directories)))
(for-each (match-lambda (for-each (match-lambda
((env-var (directories ...) separator) ((env-var (directories ...) separator)
@ -65,6 +78,15 @@ (define input-directories
#:separator separator))) #:separator separator)))
search-paths) search-paths)
(when native-search-paths
;; Search paths for native inputs, when cross building.
(for-each (match-lambda
((env-var (directories ...) separator)
(set-path-environment-variable env-var directories
native-input-directories
#:separator separator)))
native-search-paths))
;; Dump the environment variables as a shell script, for handy debugging. ;; Dump the environment variables as a shell script, for handy debugging.
(system "export > environment-variables")) (system "export > environment-variables"))
@ -102,7 +124,8 @@ (define* (patch #:key (patches '()) (patch-flags '("--batch" "-p1"))
(append patch-flags (list "--input" p))))) (append patch-flags (list "--input" p)))))
patches)) patches))
(define* (configure #:key inputs outputs (configure-flags '()) out-of-source? (define* (configure #:key target native-inputs inputs outputs
(configure-flags '()) out-of-source?
#:allow-other-keys) #:allow-other-keys)
(define (package-name) (define (package-name)
(let* ((out (assoc-ref outputs "out")) (let* ((out (assoc-ref outputs "out"))
@ -119,7 +142,7 @@ (define (package-name)
(libdir (assoc-ref outputs "lib")) (libdir (assoc-ref outputs "lib"))
(includedir (assoc-ref outputs "include")) (includedir (assoc-ref outputs "include"))
(docdir (assoc-ref outputs "doc")) (docdir (assoc-ref outputs "doc"))
(bash (or (and=> (assoc-ref inputs "bash") (bash (or (and=> (assoc-ref (or native-inputs inputs) "bash")
(cut string-append <> "/bin/bash")) (cut string-append <> "/bin/bash"))
"/bin/sh")) "/bin/sh"))
(flags `(,(string-append "CONFIG_SHELL=" bash) (flags `(,(string-append "CONFIG_SHELL=" bash)
@ -148,6 +171,9 @@ (define (package-name)
(list (string-append "--docdir=" docdir (list (string-append "--docdir=" docdir
"/doc/" (package-name))) "/doc/" (package-name)))
'()) '())
,@(if target ; cross building
(list (string-append "--host=" target))
'())
,@configure-flags)) ,@configure-flags))
(abs-srcdir (getcwd)) (abs-srcdir (getcwd))
(srcdir (if out-of-source? (srcdir (if out-of-source?
@ -230,17 +256,20 @@ (define bindirs
bindirs))) bindirs)))
#t) #t)
(define* (strip #:key outputs (strip-binaries? #t) (define* (strip #:key target outputs (strip-binaries? #t)
(strip-command (if target
(string-append target "-strip")
"strip"))
(strip-flags '("--strip-debug")) (strip-flags '("--strip-debug"))
(strip-directories '("lib" "lib64" "libexec" (strip-directories '("lib" "lib64" "libexec"
"bin" "sbin")) "bin" "sbin"))
#:allow-other-keys) #:allow-other-keys)
(define (strip-dir dir) (define (strip-dir dir)
(format #t "stripping binaries in ~s with flags ~s~%" (format #t "stripping binaries in ~s with ~s and flags ~s~%"
dir strip-flags) dir strip-command strip-flags)
(file-system-fold (const #t) (file-system-fold (const #t)
(lambda (path stat result) ; leaf (lambda (path stat result) ; leaf
(zero? (apply system* "strip" (zero? (apply system* strip-command
(append strip-flags (list path))))) (append strip-flags (list path)))))
(const #t) ; down (const #t) ; down
(const #t) ; up (const #t) ; up

View file

@ -1,138 +0,0 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build gnu-cross-build)
#:use-module (guix build utils)
#:use-module ((guix build gnu-build-system)
#:renamer (symbol-prefix-proc 'build:))
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (%standard-cross-phases
gnu-cross-build))
;;; Commentary:
;;;
;;; Extension of `gnu-build-system.scm' to support cross-compilation.
;;;
;;; Code:
(define* (set-paths #:key inputs native-inputs
(search-paths '()) (native-search-paths '())
#:allow-other-keys)
(define input-directories
(match inputs
(((_ . dir) ...)
dir)))
(define native-input-directories
(match native-inputs
(((_ . dir) ...)
dir)))
;; $PATH must refer only to native (host) inputs since target inputs are not
;; executable.
(set-path-environment-variable "PATH" '("bin" "sbin")
native-input-directories)
;; Search paths for target inputs.
(for-each (match-lambda
((env-var (directories ...) separator)
(set-path-environment-variable env-var directories
input-directories
#:separator separator)))
search-paths)
;; Search paths for native inputs.
(for-each (match-lambda
((env-var (directories ...) separator)
(set-path-environment-variable env-var directories
native-input-directories
#:separator separator)))
native-search-paths)
;; Dump the environment variables as a shell script, for handy debugging.
(system "export > environment-variables"))
(define* (configure #:key
inputs outputs (configure-flags '()) out-of-source?
target native-inputs
#:allow-other-keys)
(format #t "configuring for cross-compilation to `~a'~%" target)
(apply (assoc-ref build:%standard-phases 'configure)
#:configure-flags (cons (string-append "--host=" target)
configure-flags)
;; XXX: The underlying `configure' phase looks for Bash among
;; #:inputs, so fool it this way.
#:inputs native-inputs
#:outputs outputs
#:out-of-source? out-of-source?
'()))
(define* (strip #:key target outputs (strip-binaries? #t)
(strip-flags '("--strip-debug"))
(strip-directories '("lib" "lib64" "libexec"
"bin" "sbin"))
#:allow-other-keys)
;; TODO: The only difference with `strip' in gnu-build-system.scm is the
;; name of the strip command; factorize it.
(define (strip-dir dir)
(format #t "stripping binaries in ~s with flags ~s~%"
dir strip-flags)
(file-system-fold (const #t)
(lambda (path stat result) ; leaf
(zero? (apply system*
(string-append target "-strip")
(append strip-flags (list path)))))
(const #t) ; down
(const #t) ; up
(const #t) ; skip
(lambda (path stat errno result)
(format (current-error-port)
"strip: failed to access `~a': ~a~%"
path (strerror errno))
#f)
#t
dir))
(or (not strip-binaries?)
(every strip-dir
(append-map (match-lambda
((_ . dir)
(filter-map (lambda (d)
(let ((sub (string-append dir "/" d)))
(and (directory-exists? sub) sub)))
strip-directories)))
outputs))))
(define %standard-cross-phases
;; The standard phases when cross-building.
(let ((replacements `((set-paths ,set-paths)
(configure ,configure)
(strip ,strip))))
(fold (lambda (replacement phases)
(match replacement
((name proc)
(alist-replace name proc phases))))
(alist-delete 'check build:%standard-phases)
replacements)))
;;; gnu-cross-build.scm ends here