guix/build-system/linux-module.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
   3 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix build-system linux-module)
  21   #:use-module (guix store)
  22   #:use-module (guix utils)
  23   #:use-module (guix derivations)
  24   #:use-module (guix search-paths)
  25   #:use-module (guix build-system)
  26   #:use-module (guix build-system gnu)
  27   #:use-module (guix packages)
  28   #:use-module (ice-9 match)
  29   #:export (%linux-module-build-system-modules
  30             linux-module-build
  31             linux-module-build-system))
  32
  33 ;; Commentary:
  34 ;;
  35 ;; Code:
  36
  37 (define %linux-module-build-system-modules
  38   ;; Build-side modules imported by default.
  39   `((guix build linux-module-build-system)
  40     ,@%gnu-build-system-modules))
  41
  42 (define (default-linux)
  43   "Return the default Linux package."
  44
  45   ;; Do not use `@' to avoid introducing circular dependencies.
  46   (let ((module (resolve-interface '(gnu packages linux))))
  47     (module-ref module 'linux-libre)))
  48
  49 (define (system->arch system)
  50   (let ((module (resolve-interface '(gnu packages linux))))
  51     ((module-ref module 'system->linux-architecture) system)))
  52
  53 (define (make-linux-module-builder linux)
  54   (package
  55     (inherit linux)
  56     (name (string-append (package-name linux) "-module-builder"))
  57     (inputs
  58      `(("linux" ,linux)))
  59     (arguments
  60      (substitute-keyword-arguments (package-arguments linux)
  61       ((#:phases phases)
  62        `(modify-phases ,phases
  63           (replace 'build
  64             (lambda _
  65               (invoke "make" "modules_prepare")))
  66           (delete 'strip) ; faster.
  67           (replace 'install
  68             (lambda* (#:key inputs outputs #:allow-other-keys)
  69               (let* ((out (assoc-ref outputs "out"))
  70                      (out-lib-build (string-append out "/lib/modules/build")))
  71                 ;; Delete some huge items that we probably don't need.
  72                 ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig,
  73                 ;; scripts, include, ".config".
  74                 (copy-recursively "." out-lib-build)
  75                 (for-each (lambda (name)
  76                             (when (file-exists? name)
  77                             (delete-file-recursively name)))
  78                  (map (lambda (name)
  79                         (string-append out-lib-build "/" name))
  80                   '("arch" ; 137 MB
  81                     ;"tools" ; 44 MB ; Note: is built by our 'build phase.
  82                     "tools/testing" ; 14 MB
  83                     "tools/perf" ; 17 MB
  84                     "drivers" ; 600 MB
  85                     "Documentation" ; 52 MB
  86                     "fs" ; 43 MB
  87                     "net" ; 33 MB
  88                     "samples" ; 2 MB
  89                     "sound"))) ; 40 MB
  90                 ;; Reinstate arch/**/dts since "scripts/dtc" depends on it.
  91                 ;; Reinstate arch/**/include directories.
  92                 ;; Reinstate arch/**/Makefile.
  93                 ;; Reinstate arch/**/module.lds.
  94                 (for-each
  95                  (lambda (name)
  96                    (mkdir-p (dirname (string-append out-lib-build "/" name)))
  97                    (copy-recursively name
  98                                      (string-append out-lib-build "/" name)))
  99                  (append (find-files "arch" "^(dts|include)$" #:directories? #t)
 100                          (find-files "arch" "^(Makefile|module.lds)$")))
 101                 (let* ((linux (assoc-ref inputs "linux")))
 102                   (install-file (string-append linux "/System.map")
 103                                 out-lib-build)
 104                   (let ((source (string-append linux "/Module.symvers")))
 105                     (when (file-exists? source)
 106                         (install-file source out-lib-build))))
 107                 #t)))))))))
 108
 109 (define* (lower name
 110                 #:key source inputs native-inputs outputs
 111                 system target
 112                 (linux (default-linux))
 113                 #:allow-other-keys
 114                 #:rest arguments)
 115   "Return a bag for NAME."
 116   (define private-keywords
 117     `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs
 118       ,@(if target '() '(#:target))))
 119
 120   (bag
 121     (name name)
 122     (system system) (target target)
 123     (build-inputs `(,@(if source
 124                           `(("source" ,source))
 125                           '())
 126                     ,@native-inputs
 127                     ;; TODO: Remove "gmp", "mpfr", "mpc" since they are
 128                     ;; only needed to compile the gcc plugins.  Maybe
 129                     ;; remove "flex", "bison", "elfutils", "perl",
 130                     ;; "openssl".  That leaves very little ("bc", "gcc",
 131                     ;; "kmod").
 132                     ,@(package-native-inputs linux)
 133                     ,@(if target
 134                           ;; Use the standard cross inputs of
 135                           ;; 'gnu-build-system'.
 136                           (standard-cross-packages target 'host)
 137                           '())
 138                     ;; Keep the standard inputs of 'gnu-build-system'.
 139                     ,@(standard-packages)))
 140     (host-inputs `(,@inputs
 141                    ("linux" ,linux)
 142                    ("linux-module-builder"
 143                     ,(make-linux-module-builder linux))))
 144     (target-inputs (if target
 145                        (standard-cross-packages target 'target)
 146                        '()))
 147     (outputs outputs)
 148     (build (if target linux-module-build-cross linux-module-build))
 149     (arguments (strip-keyword-arguments private-keywords arguments))))
 150
 151 (define* (linux-module-build store name inputs
 152                              #:key
 153                              target
 154                              (search-paths '())
 155                              (tests? #t)
 156                              (phases '(@ (guix build linux-module-build-system)
 157                                          %standard-phases))
 158                              (outputs '("out"))
 159                              (make-flags ''())
 160                              (system (%current-system))
 161                              (guile #f)
 162                              (substitutable? #t)
 163                              (imported-modules
 164                               %linux-module-build-system-modules)
 165                              (modules '((guix build linux-module-build-system)
 166                                         (guix build utils))))
 167   "Build SOURCE using LINUX, and with INPUTS."
 168   (define builder
 169     `(begin
 170        (use-modules ,@modules)
 171        (linux-module-build #:name ,name
 172                      #:source ,(match (assoc-ref inputs "source")
 173                                       (((? derivation? source))
 174                                        (derivation->output-path source))
 175                                       ((source)
 176                                        source)
 177                                       (source
 178                                         source))
 179                      #:search-paths ',(map search-path-specification->sexp
 180                                            search-paths)
 181                      #:phases ,phases
 182                      #:system ,system
 183                      #:target ,target
 184                      #:arch ,(system->arch (or target system))
 185                      #:tests? ,tests?
 186                      #:outputs %outputs
 187                      #:make-flags ,make-flags
 188                      #:inputs %build-inputs)))
 189
 190   (define guile-for-build
 191     (match guile
 192       ((? package?)
 193        (package-derivation store guile system #:graft? #f))
 194       (#f                                         ; the default
 195        (let* ((distro (resolve-interface '(gnu packages commencement)))
 196               (guile  (module-ref distro 'guile-final)))
 197          (package-derivation store guile system #:graft? #f)))))
 198
 199   (build-expression->derivation store name builder
 200                                 #:system system
 201                                 #:inputs inputs
 202                                 #:modules imported-modules
 203                                 #:outputs outputs
 204                                 #:guile-for-build guile-for-build
 205                                 #:substitutable? substitutable?))
 206
 207 (define* (linux-module-build-cross
 208           store name
 209           #:key
 210           target native-drvs target-drvs
 211           (guile #f)
 212           (outputs '("out"))
 213           (make-flags ''())
 214           (search-paths '())
 215           (native-search-paths '())
 216           (tests? #f)
 217           (phases '(@ (guix build linux-module-build-system)
 218                       %standard-phases))
 219           (system (%current-system))
 220           (substitutable? #t)
 221           (imported-modules
 222            %linux-module-build-system-modules)
 223           (modules '((guix build linux-module-build-system)
 224                      (guix build utils))))
 225   (define builder
 226     `(begin
 227        (use-modules ,@modules)
 228        (let ()
 229          (define %build-host-inputs
 230            ',(map (match-lambda
 231                     ((name (? derivation? drv) sub ...)
 232                      `(,name . ,(apply derivation->output-path drv sub)))
 233                     ((name path)
 234                      `(,name . ,path)))
 235                   native-drvs))
 236
 237          (define %build-target-inputs
 238            ',(map (match-lambda
 239                     ((name (? derivation? drv) sub ...)
 240                      `(,name . ,(apply derivation->output-path drv sub)))
 241                     ((name (? package? pkg) sub ...)
 242                      (let ((drv (package-cross-derivation store pkg
 243                                                           target system)))
 244                        `(,name . ,(apply derivation->output-path drv sub))))
 245                     ((name path)
 246                      `(,name . ,path)))
 247                   target-drvs))
 248
 249          (linux-module-build #:name ,name
 250                              #:source ,(match (assoc-ref native-drvs "source")
 251                                          (((? derivation? source))
 252                                           (derivation->output-path source))
 253                                          ((source)
 254                                           source)
 255                                          (source
 256                                           source))
 257                              #:system ,system
 258                              #:target ,target
 259                              #:arch ,(system->arch (or target system))
 260                              #:outputs %outputs
 261                              #:make-flags ,make-flags
 262                              #:inputs %build-target-inputs
 263                              #:native-inputs %build-host-inputs
 264                              #:search-paths
 265                              ',(map search-path-specification->sexp
 266                                     search-paths)
 267                              #:native-search-paths
 268                              ',(map
 269                                 search-path-specification->sexp
 270                                 native-search-paths)
 271                              #:phases ,phases
 272                              #:tests? ,tests?))))
 273
 274   (define guile-for-build
 275     (match guile
 276       ((? package?)
 277        (package-derivation store guile system #:graft? #f))
 278       (#f                                         ; the default
 279        (let* ((distro (resolve-interface '(gnu packages commencement)))
 280               (guile  (module-ref distro 'guile-final)))
 281          (package-derivation store guile system #:graft? #f)))))
 282
 283   (build-expression->derivation store name builder
 284                                 #:system system
 285                                 #:inputs (append native-drvs target-drvs)
 286                                 #:outputs outputs
 287                                 #:modules imported-modules
 288                                 #:guile-for-build guile-for-build
 289                                 #:substitutable? substitutable?))
 290
 291 (define linux-module-build-system
 292   (build-system
 293     (name 'linux-module)
 294     (description "The Linux module build system")
 295     (lower lower)))
 296
 297 ;;; linux-module.scm ends here