build-system: linux-module: Fix cross compilation.

* guix/build-system/linux-module.scm (default-kmod, default-gcc): Delete
procedures.
(system->arch): New procedure.
(make-linux-module-builder)[native-inputs]: Move linux...
[inputs]: ...to here.
(linux-module-build-cross): New procedure.
(linux-module-build): Add TARGET.  Pass TARGET and ARCH to build side.
(lower): Allow cross-compilation.  Move "linux" and "linux-module-builder"
to host-inputs.  Add target-inputs.  Call linux-module-build-cross if
TARGET is set, linux-module-build otherwise.
* guix/build/linux-module-build-system.scm (configure): Add ARCH argument.
(linux-module-build): Adjust comment.

Signed-off-by: Danny Milosavljevic <dannym@scratchpost.org>

2 files changed, 132 insertions, 47 deletions

diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index 1e1a07d0a2..ca104f7c75 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,27 +46,16 @@
   (let ((module (resolve-interface '(gnu packages linux))))
     (module-ref module 'linux-libre)))
 
-(define (default-kmod)
-  "Return the default kmod package."
-
-  ;; Do not use `@' to avoid introducing circular dependencies.
+(define (system->arch system)
   (let ((module (resolve-interface '(gnu packages linux))))
-    (module-ref module 'kmod)))
-
-(define (default-gcc)
-  "Return the default gcc package."
-
-  ;; Do not use `@' to avoid introducing circular dependencies.
-  (let ((module (resolve-interface '(gnu packages gcc))))
-    (module-ref module 'gcc-7)))
+    ((module-ref module 'system->linux-architecture) system)))
 
 (define (make-linux-module-builder linux)
   (package
     (inherit linux)
     (name (string-append (package-name linux) "-module-builder"))
-    (native-inputs
-     `(("linux" ,linux)
-       ,@(package-native-inputs linux)))
+    (inputs
+     `(("linux" ,linux)))
     (arguments
      (substitute-keyword-arguments (package-arguments linux)
       ((#:phases phases)
@@ -97,33 +87,43 @@
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs))
-
-  (and (not target)                               ;XXX: no cross-compilation
-       (bag
-         (name name)
-         (system system)
-         (host-inputs `(,@(if source
-                              `(("source" ,source))
-                              '())
-                        ,@inputs
-                        ,@(standard-packages)))
-         (build-inputs `(("linux" ,linux) ; for "Module.symvers".
-                         ("linux-module-builder"
-                         ,(make-linux-module-builder linux))
-                         ,@native-inputs
-                         ;; TODO: Remove "gmp", "mpfr", "mpc" since they are
-                         ;; only needed to compile the gcc plugins.  Maybe
-                         ;; remove "flex", "bison", "elfutils", "perl",
-                         ;; "openssl".  That leaves very little ("bc", "gcc",
-                         ;; "kmod").
-                         ,@(package-native-inputs linux)))
-         (outputs outputs)
-         (build linux-module-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
+    `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs
+      ,@(if target '() '(#:target))))
+
+  (bag
+    (name name)
+    (system system) (target target)
+    (build-inputs `(,@(if source
+                          `(("source" ,source))
+                          '())
+                    ,@native-inputs
+                    ;; TODO: Remove "gmp", "mpfr", "mpc" since they are
+                    ;; only needed to compile the gcc plugins.  Maybe
+                    ;; remove "flex", "bison", "elfutils", "perl",
+                    ;; "openssl".  That leaves very little ("bc", "gcc",
+                    ;; "kmod").
+                    ,@(package-native-inputs linux)
+                    ,@(if target
+                          ;; Use the standard cross inputs of
+                          ;; 'gnu-build-system'.
+                          (standard-cross-packages target 'host)
+                          '())
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(standard-packages)))
+    (host-inputs `(,@inputs
+                   ("linux" ,linux)
+                   ("linux-module-builder"
+                    ,(make-linux-module-builder linux))))
+    (target-inputs (if target
+                       (standard-cross-packages target 'target)
+                       '()))
+    (outputs outputs)
+    (build (if target linux-module-build-cross linux-module-build))
+    (arguments (strip-keyword-arguments private-keywords arguments))))
 
 (define* (linux-module-build store name inputs
                              #:key
+                             target
                              (search-paths '())
                              (tests? #t)
                              (phases '(@ (guix build linux-module-build-system)
@@ -152,6 +152,8 @@
                                            search-paths)
                      #:phases ,phases
                      #:system ,system
+                     #:target ,target
+                     #:arch ,(system->arch (or target system))
                      #:tests? ,tests?
                      #:outputs %outputs
                      #:inputs %build-inputs)))
@@ -173,6 +175,88 @@
                                 #:guile-for-build guile-for-build
                                 #:substitutable? substitutable?))
 
+(define* (linux-module-build-cross
+          store name
+          #:key
+          target native-drvs target-drvs
+          (guile #f)
+          (outputs '("out"))
+          (search-paths '())
+          (native-search-paths '())
+          (tests? #f)
+          (phases '(@ (guix build linux-module-build-system)
+                      %standard-phases))
+          (system (%current-system))
+          (substitutable? #t)
+          (imported-modules
+           %linux-module-build-system-modules)
+          (modules '((guix build linux-module-build-system)
+                     (guix build utils))))
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (let ()
+         (define %build-host-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name path)
+                     `(,name . ,path)))
+                  native-drvs))
+
+         (define %build-target-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name (? package? pkg) sub ...)
+                     (let ((drv (package-cross-derivation store pkg
+                                                          target system)))
+                       `(,name . ,(apply derivation->output-path drv sub))))
+                    ((name path)
+                     `(,name . ,path)))
+                  target-drvs))
+
+         (linux-module-build #:name ,name
+                             #:source ,(match (assoc-ref native-drvs "source")
+                                         (((? derivation? source))
+                                          (derivation->output-path source))
+                                         ((source)
+                                          source)
+                                         (source
+                                          source))
+                             #:system ,system
+                             #:target ,target
+                             #:arch ,(system->arch (or target system))
+                             #:outputs %outputs
+                             #:inputs %build-target-inputs
+                             #:native-inputs %build-host-inputs
+                             #:search-paths
+                             ',(map search-path-specification->sexp
+                                    search-paths)
+                             #:native-search-paths
+                             ',(map
+                                search-path-specification->sexp
+                                native-search-paths)
+                             #:phases ,phases
+                             #:tests? ,tests?))))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                                         ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:system system
+                                #:inputs (append native-drvs target-drvs)
+                                #:outputs outputs
+                                #:modules imported-modules
+                                #:guile-for-build guile-for-build
+                                #:substitutable? substitutable?))
+
 (define linux-module-build-system
   (build-system
     (name 'linux-module)
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 8145d5a724..73d6b101f6 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,14 +34,13 @@
 ;; Code:
 
 ;; Copied from make-linux-libre's "configure" phase.
-(define* (configure #:key inputs target #:allow-other-keys)
+(define* (configure #:key inputs target arch #:allow-other-keys)
   (setenv "KCONFIG_NOTIMESTAMP" "1")
   (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
-  ;(let ((arch ,(system->linux-architecture
-  ;                         (or (%current-target-system)
-  ;                             (%current-system)))))
-  ;  (setenv "ARCH" arch)
-  ;  (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")))
+
+  (setenv "ARCH" arch)
+  (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))
+
   (when target
     (setenv "CROSS_COMPILE" (string-append target "-"))
     (format #t "`CROSS_COMPILE' set to `~a'~%"
@@ -85,8 +85,9 @@
     (replace 'install install)))
 
 (define* (linux-module-build #:key inputs (phases %standard-phases)
-                       #:allow-other-keys #:rest args)
-  "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance."
+                             #:allow-other-keys #:rest args)
+  "Build the given package, applying all of PHASES in order, with a Linux
+kernel in attendance."
   (apply gnu:gnu-build
          #:inputs inputs #:phases phases
          args))