[bug#49025] [PATCH v5 20/20] meson: Support cross-compilation.

[Maxime Devos <maximedevos@telenet.be>]

For cross-compilation, meson needs to be passed a
‘cross file’ with information on the architecture,
CPU type, endianness and operating system, and the
name of the cross-compiler binaries.

The new module (guix build meson-configuration) has
some utilities for writing these cross files, used
by 'make-cross-file' in a G-exp.  The values for
the cross file are generated by 'make-machine-alist'
and 'make-binaries-alist'.

'make-machine-alist' and 'make-binaries-alist' live
on the host side, such that new architectures and operating
systems can be added without causing rebuilds for old
architectures.

Currently, only GNU/Hurd, GNU/Linux, MinGW, x86-32 and
x86-64 are supported by 'make-machine-alist'. For other
architectures, someone needs to figure out what to
use as ‘CPU type’ first.  Only i686-linux-gnu and
aarch64-linux-gnu have been tested.  The first target
is only tested in a previous version of this patch
series.

This has been tested with:

$ ./pre-inst-env guix build glib --target=aarch64-linux-gnu

on a x86_64-linux system.  ‘If it compiles, it should work.’

* guix/build/meson-configuration.scm
  (configuration-port): New parameter.
  (write-section-header): New procedure.
  (write-assignment): New procedure.
  (write-assignments): New procedure.
* guix/build-system/meson.scm
  (target-hurd?): New predicate.
  (make-machine-alist): New procedure.
  (make-binaries-alist): New procedure.
  (make-cross-file): New procedure.
  (meson-cross-build): New procedure.
  (lower)[build-inputs]: Add standard cross packages when cross-compiling.
  Do not include regular 'inputs' when cross-compiling.
  (lower)[host-inputs]: Include 'inputs' when cross-compiling.
  (lower)[target-inputs]: Add cross packages when cross-compiling.
  (lower)[build]: Call 'meson-cross-build' instead of 'cross-build'
  when cross-compiling.
  (lower)[target]: Set it.
  (lower)[private-keywords]: Do not remove #:target when cross-compiling.
---
 Makefile.am                        |   1 +
 guix/build-system/meson.scm        | 201 ++++++++++++++++++++++++++---
 guix/build/meson-configuration.scm |  71 ++++++++++
 3 files changed, 254 insertions(+), 19 deletions(-)
 create mode 100644 guix/build/meson-configuration.scm

diff --git a/Makefile.am b/Makefile.am
index 05f013e3c2..6c17ab8492 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -234,6 +234,7 @@ MODULES =					\
   guix/build/emacs-utils.scm			\
   guix/build/java-utils.scm			\
   guix/build/lisp-utils.scm			\
+  guix/build/meson-configuration.scm		\
   guix/build/maven/java.scm			\
   guix/build/maven/plugin.scm			\
   guix/build/maven/pom.scm			\
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index 5adc0f92c8..55311f85f0 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
 ;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,7 +31,8 @@
   #:use-module (guix packages)
   #:use-module (ice-9 match)
   #:export (%meson-build-system-modules
-            meson-build-system))
+            meson-build-system
+            make-cross-file))
 
 ;; Commentary:
 ;;
@@ -40,6 +42,66 @@
 ;;
 ;; Code:
 
+(define (target-hurd? triplet)
+  (and (string-suffix? "-gnu" triplet)
+       (not (string-contains triplet "linux"))))
+
+(define (make-machine-alist triplet)
+  "Make an association list describing what should go into
+the ‘host_machine’ section of the cross file when cross-compiling
+for TRIPLET."
+  `((system . ,(cond ((target-hurd? triplet) "gnu")
+                     ((target-linux? triplet) "linux")
+                     ((target-mingw? triplet) "windows")
+                     (#t (error "meson: unknown operating system"))))
+    (cpu_family . ,(cond ((target-x86-32? triplet) "x86")
+                         ((target-x86-64? triplet) "x86_64")
+                         ((target-arm32? triplet) "arm")
+                         ((target-aarch64? triplet) "aarch64")
+                         ((target-powerpc? triplet)
+                          (if (target-64bit? triplet)
+                              "ppc64"
+                              "ppc"))
+                         (#t (error "meson: unknown architecture"))))
+    (cpu . ,(cond ((target-x86-32? triplet) ; i386, ..., i686
+                   (substring triplet 0 4))
+                  ((target-x86-64? triplet) "x86_64")
+                  ((target-aarch64? triplet) "armv8-a")
+                  (#t (error "meson: unknown CPU"))))
+    (endian . ,(cond ((string-prefix? "powerpc64le-" triplet) "little")
+                     ((string-prefix? "mips64el-" triplet) "little")
+                     ((target-x86-32? triplet) "little")
+                     ((target-x86-64? triplet) "little")
+                     ;; At least in Guix.  Aarch64 has a big-endian
+                     ;; mode as well.
+                     ((target-aarch64? triplet) "little")
+                     (#t (error "meson: unknown architecture"))))))
+
+(define (make-binaries-alist triplet)
+  "Make an associatoin list describing what should go into
+the ‘binaries’ section of the cross file when cross-compiling for
+TRIPLET."
+  `((c . ,(cc-for-target triplet))
+    (cpp . ,(cxx-for-target triplet))
+    (pkgconfig . ,(pkg-config-for-target triplet))
+    (objcopy . ,(string-append triplet "-objcopy"))
+    (ar . ,(string-append triplet "-ar"))
+    (ld . ,(string-append triplet "-ld"))
+    (strip . ,(string-append triplet "-strip"))))
+
+(define (make-cross-file triplet)
+  (computed-file "cross-file"
+    (with-imported-modules '((guix build meson-configuration))
+      #~(begin
+          (use-modules (guix build meson-configuration))
+          (call-with-output-file #$output
+            (lambda (f)
+              (parameterize ((configuration-port f))
+                (write-section-header "host_machine")
+                (write-assignments '#$(make-machine-alist triplet))
+                (write-section-header "binaries")
+                (write-assignments '#$(make-binaries-alist triplet)))))))))
+
 (define %meson-build-system-modules
   ;; Build-side modules imported by default.
   `((guix build meson-build-system)
@@ -68,24 +130,34 @@
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    `(#:meson #:ninja #:inputs #:native-inputs #:outputs #:target))
-
-  (and (not target) ;; TODO: add support for cross-compilation.
-       (bag
-         (name name)
-         (system system)
-         (build-inputs `(("meson" ,meson)
-                         ("ninja" ,ninja)
-                         ,@native-inputs
-                         ,@inputs
-                         ;; Keep the standard inputs of 'gnu-build-system'.
-                         ,@(standard-packages)))
-         (host-inputs (if source
-                          `(("source" ,source))
-                          '()))
-         (outputs outputs)
-         (build meson-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
+    `(#:meson #:ninja #:inputs #:native-inputs #:outputs
+      ,@(if target
+            '()
+            '(#:target))))
+
+  (bag
+    (name name)
+    (system system) (target target)
+    (build-inputs `(("meson" ,meson)
+                    ("ninja" ,ninja)
+                    ,@native-inputs
+                    ,@(if target '() inputs)
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(if target
+                          (standard-cross-packages target 'host)
+                          '())
+                    ,@(standard-packages)))
+    (host-inputs `(,@(if source
+                         `(("source" ,source))
+                         '())
+                   ,@(if target inputs '())))
+    ;; Keep the standard inputs of 'gnu-buid-system'.
+    (target-inputs (if target
+                       (standard-cross-packages target 'target)
+                       '()))
+    (outputs outputs)
+    (build (if target meson-cross-build meson-build))
+    (arguments (strip-keyword-arguments private-keywords arguments))))
 
 (define* (meson-build name inputs
                       #:key
@@ -161,6 +233,97 @@ has a 'meson.build' file."
                       #:disallowed-references disallowed-references
                       #:guile-for-build guile)))
 
+(define* (meson-cross-build name
+                            #:key
+                            target
+                            build-inputs host-inputs target-inputs
+                            guile source
+                            (outputs '("out"))
+                            (configure-flags ''())
+                            (search-paths '())
+                            (native-search-paths '())
+
+                            (build-type "debugoptimized")
+                            (tests? #f)
+                            (test-target "test")
+                            (glib-or-gtk? #f)
+                            (parallel-build? #t)
+                            (parallel-tests? #f)
+                            (validate-runpath? #t)
+                            (patch-shebangs? #t)
+                            (strip-binaries? #t)
+                            (strip-flags ''("--strip-debug"))
+                            (strip-directories ''("lib" "lib64" "libexec"
+                                                  "bin" "sbin"))
+                            (elf-directories ''("lib" "lib64" "libexec"
+                                                "bin" "sbin"))
+                            (phases '%standard-phases)
+                            (system (%current-system))
+                            (imported-modules %meson-build-system-modules)
+                            (modules '((guix build meson-build-system)
+                                       (guix build utils)))
+                            allowed-references
+                            disallowed-references)
+  "Cross-build SOURCE for TARGET using MESON, and with INPUTS, assuming that
+SOURCE has a 'meson.build' file."
+  (define cross-file
+    (make-cross-file target))
+  (define inputs
+    (if (null? target-inputs)
+        (input-tuples->gexp host-inputs)
+        #~(append #$(input-tuples->gexp host-inputs)
+                  #+(input-tuples->gexp target-inputs))))
+  (define builder
+    (with-imported-modules imported-modules
+      #~(begin
+          (use-modules #$@(sexp->gexp modules))
+
+          (define build-phases
+            #$(let ((phases (if (pair? phases) (sexp->gexp phases) phases)))
+                (if glib-or-gtk?
+                    phases
+                    #~(modify-phases #$phases
+                        (delete 'glib-or-gtk-compile-schemas)
+                        (delete 'glib-or-gtk-wrap)))))
+
+          ;; Do not use 'with-build-variables', as there should be
+          ;; no reason to use %build-inputs and friends.
+          (meson-build #:source #+source
+                       #:system #$system
+                       #:outputs #$(outputs->gexp outputs)
+                       #:inputs #$inputs
+                       #:native-inputs #+(input-tuples->gexp build-inputs)
+                       #:search-paths '#$(sexp->gexp
+                                          (map search-path-specification->sexp
+                                                     search-paths))
+                       #:native-search-paths '#$(sexp->gexp
+                                                 (map search-path-specification->sexp
+                                                      native-search-paths))
+                       #:phases build-phases
+                       #:configure-flags `("--cross-file" #+cross-file
+                                           ,@#$(sexp->gexp configure-flags))
+                       #:build-type #$build-type
+                       #:tests? #$tests?
+                       #:test-target #$test-target
+                       #:parallel-build? #$parallel-build?
+                       #:parallel-tests? #$parallel-tests?
+                       #:validate-runpath? #$validate-runpath?
+                       #:patch-shebangs? #$patch-shebangs?
+                       #:strip-binaries? #$strip-binaries?
+                       #:strip-flags #$(sexp->gexp strip-flags)
+                       #:strip-directories #$(sexp->gexp strip-directories)
+                       #:elf-directories #$(sexp->gexp elf-directories)))))
+
+  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+                                                  system #:graft? #f)))
+    (gexp->derivation name builder
+                      #:system system
+                      #:target target
+                      #:substitutable? substitutable?
+                      #:allowed-references allowed-references
+                      #:disallowed-references disallowed-references
+                      #:guile-for-build guile)))
+
 (define meson-build-system
   (build-system
     (name 'meson)
diff --git a/guix/build/meson-configuration.scm b/guix/build/meson-configuration.scm
new file mode 100644
index 0000000000..81b4eaa7e1
--- /dev/null
+++ b/guix/build/meson-configuration.scm
@@ -0,0 +1,71 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;;
+;;; 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 meson-configuration)
+  #:use-module (ice-9 match)
+  #:export (write-section-header write-assignment
+            write-assignments make-machine-alist
+            configuration-port))
+
+;; Commentary:
+;;
+;; Utilities for generating a ‘Cross build definition file’ for
+;; the Meson build system.  Configuration values are currently
+;; never escaped.  In practice this is unlikely to be a problem
+;; in the build environment.
+;;
+;; Code:
+
+(define configuration-port
+  (fluid->parameter (make-unbound-fluid)))
+
+(define (write-section-header section-name)
+  "Write a section header for section named SECTION-NAME
+to the configuration port."
+  (format (configuration-port) "[~a]~%" section-name))
+
+(define (write-assignment key value)
+  "Write an assignment of VALUE to KEY to the configuration
+port.  VALUE must be a string (without any special characters
+such as quotes), a boolean or an integer.  Lists are currently
+not supported"
+  (define port (configuration-port))
+  (match value
+    ((? string?)
+     (format port "~a = '~a'~%" key value))
+    ((? integer?)
+     (format port "~a = ~a~%" key value))
+    (#f
+     (format port "~a = true~%" key))
+    (#t
+     (format port "~a = false~%" key))))
+
+(define* (write-assignments alist)
+  "Write the assignments in ALIST, an association list,
+to the configuration port."
+  (for-each (match-lambda
+              ((key . value)
+               (write-assignment key value)))
+            alist))
+
+(define* (make-machine-alist #:key system cpu-family cpu endian)
+  "Make an association list for the [host_machine] section."
+  `((system . ,system)
+    (cpu-family . ,cpu-family)
+    (cpu . ,cpu)
+    (endian . ,endian)))
-- 
2.32.0