guix/build-system/linux-module.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build-system linux-module)
  20   #:use-module (guix store)
  21   #:use-module (guix utils)
  22   #:use-module (guix derivations)
  23   #:use-module (guix search-paths)
  24   #:use-module (guix build-system)
  25   #:use-module (guix build-system gnu)
  26   #:use-module (guix packages)
  27   #:use-module (ice-9 match)
  28   #:export (%linux-module-build-system-modules
  29             linux-module-build
  30             linux-module-build-system))
  31
  32 ;; Commentary:
  33 ;;
  34 ;; Code:
  35
  36 (define %linux-module-build-system-modules
  37   ;; Build-side modules imported by default.
  38   `((guix build linux-module-build-system)
  39     ,@%gnu-build-system-modules))
  40
  41 (define (default-linux)
  42   "Return the default Linux package."
  43
  44   ;; Do not use `@' to avoid introducing circular dependencies.
  45   (let ((module (resolve-interface '(gnu packages linux))))
  46     (module-ref module 'linux-libre)))
  47
  48 (define (default-kmod)
  49   "Return the default kmod package."
  50
  51   ;; Do not use `@' to avoid introducing circular dependencies.
  52   (let ((module (resolve-interface '(gnu packages linux))))
  53     (module-ref module 'kmod)))
  54
  55 (define (default-gcc)
  56   "Return the default gcc package."
  57
  58   ;; Do not use `@' to avoid introducing circular dependencies.
  59   (let ((module (resolve-interface '(gnu packages gcc))))
  60     (module-ref module 'gcc-7)))
  61
  62 (define (make-linux-module-builder linux)
  63   (package
  64     (inherit linux)
  65     (name (string-append (package-name linux) "-module-builder"))
  66     (native-inputs
  67      `(("linux" ,linux)
  68        ,@(package-native-inputs linux)))
  69     (arguments
  70      (substitute-keyword-arguments (package-arguments linux)
  71       ((#:phases phases)
  72        `(modify-phases ,phases
  73           (replace 'build
  74             (lambda _
  75               (invoke "make" "modules_prepare")))
  76           (delete 'strip) ; faster.
  77           (replace 'install
  78             (lambda* (#:key inputs outputs #:allow-other-keys)
  79               (let* ((out (assoc-ref outputs "out"))
  80                      (out-lib-build (string-append out "/lib/modules/build")))
  81                 ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config".
  82                 (copy-recursively "." out-lib-build)
  83                 (let* ((linux (assoc-ref inputs "linux")))
  84                   (install-file (string-append linux "/System.map")
  85                                 out-lib-build)
  86                   (let ((source (string-append linux "/Module.symvers")))
  87                     (if (file-exists? source)
  88                         (install-file source out-lib-build))))
  89                 #t)))))))))
  90
  91 (define* (lower name
  92                 #:key source inputs native-inputs outputs
  93                 system target
  94                 (linux (default-linux))
  95                 #:allow-other-keys
  96                 #:rest arguments)
  97   "Return a bag for NAME."
  98   (define private-keywords
  99     '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs))
 100
 101   (and (not target)                               ;XXX: no cross-compilation
 102        (bag
 103          (name name)
 104          (system system)
 105          (host-inputs `(,@(if source
 106                               `(("source" ,source))
 107                               '())
 108                         ,@inputs
 109                         ,@(standard-packages)))
 110          (build-inputs `(("linux" ,linux) ; for "Module.symvers".
 111                          ("linux-module-builder"
 112                          ,(make-linux-module-builder linux))
 113                          ,@native-inputs
 114                          ;; 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").
 115                          ,@(package-native-inputs linux)))
 116          (outputs outputs)
 117          (build linux-module-build)
 118          (arguments (strip-keyword-arguments private-keywords arguments)))))
 119
 120 (define* (linux-module-build store name inputs
 121                              #:key
 122                              (search-paths '())
 123                              (tests? #t)
 124                              (phases '(@ (guix build linux-module-build-system)
 125                                          %standard-phases))
 126                              (outputs '("out"))
 127                              (system (%current-system))
 128                              (guile #f)
 129                              (imported-modules
 130                               %linux-module-build-system-modules)
 131                              (modules '((guix build linux-module-build-system)
 132                                         (guix build utils))))
 133   "Build SOURCE using LINUX, and with INPUTS."
 134   (define builder
 135     `(begin
 136        (use-modules ,@modules)
 137        (linux-module-build #:name ,name
 138                      #:source ,(match (assoc-ref inputs "source")
 139                                       (((? derivation? source))
 140                                        (derivation->output-path source))
 141                                       ((source)
 142                                        source)
 143                                       (source
 144                                         source))
 145                      #:search-paths ',(map search-path-specification->sexp
 146                                            search-paths)
 147                      #:phases ,phases
 148                      #:system ,system
 149                      #:tests? ,tests?
 150                      #:outputs %outputs
 151                      #:inputs %build-inputs)))
 152
 153   (define guile-for-build
 154     (match guile
 155       ((? package?)
 156        (package-derivation store guile system #:graft? #f))
 157       (#f                                         ; the default
 158        (let* ((distro (resolve-interface '(gnu packages commencement)))
 159               (guile  (module-ref distro 'guile-final)))
 160          (package-derivation store guile system #:graft? #f)))))
 161
 162   (build-expression->derivation store name builder
 163                                 #:system system
 164                                 #:inputs inputs
 165                                 #:modules imported-modules
 166                                 #:outputs outputs
 167                                 #:guile-for-build guile-for-build))
 168
 169 (define linux-module-build-system
 170   (build-system
 171     (name 'linux-module)
 172     (description "The Linux module build system")
 173     (lower lower)))
 174
 175 ;;; linux-module.scm ends here