139 lines
5.3 KiB
Scheme
139 lines
5.3 KiB
Scheme
;;; 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
|