Merge branch 'master' into staging

1 files changed, 125 insertions, 36 deletions

diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index ba76ab85c3..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)
@@ -78,7 +68,8 @@
             (lambda* (#:key inputs outputs #:allow-other-keys)
               (let* ((out (assoc-ref outputs "out"))
                      (out-lib-build (string-append out "/lib/modules/build")))
-                ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config".
+                ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig,
+                ;; scripts, include, ".config".
                 (copy-recursively "." out-lib-build)
                 (let* ((linux (assoc-ref inputs "linux")))
                   (install-file (string-append linux "/System.map")
@@ -96,29 +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)
@@ -147,6 +152,8 @@
                                            search-paths)
                      #:phases ,phases
                      #:system ,system
+                     #:target ,target
+                     #:arch ,(system->arch (or target system))
                      #:tests? ,tests?
                      #:outputs %outputs
                      #:inputs %build-inputs)))
@@ -168,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)