gnu: linux: New function to modify the configuration of a Linux kernel.

From: Stefan <stefan-guix@vodafonemail.de>

* gnu/packages/linux.scm (system->linux-srcarch): New function to return the
relevent folder name below arch/ in the Linux source code.
(make-linux-libre*) ['set-environment]: Splitted this new phase out of and
adding it before …
['configure]: … to allow a replacement and reuse from (modify-linux).
(modify-linux): New function to make a customized Linux package inherited
from another Linux package, which will be build with an own defconfig or
configuration changes.
(make-defconfig): Function to get a defconfig from an uri.
---
 gnu/packages/linux.scm |  132 +++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 128 insertions(+), 4 deletions(-)

diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index 51e692a8c3..983f0c2b22 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -54,6 +54,7 @@
 ;;; Copyright © 2020 David Dashyan <mail@davie.li>
 ;;; Copyright © 2020 pukkamustard <pukkamustard@posteo.net>
 ;;; Copyright © 2021 B. Wilson <elaexuotee@wilsonb.com>
+;;; Copyright © 2021 Stefan <stefan-guix@vodafonemail.de>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -165,7 +166,8 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-26)
-  #:use-module (ice-9 match))
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs))
 
 (define-public (system->linux-architecture arch)
   "Return the Linux architecture name for ARCH, a Guix system name such as
@@ -181,6 +183,21 @@
           ((string-prefix? "riscv" arch) "riscv")
           (else arch))))
 
+(define-public (system->linux-srcarch arch)
+  "Return for a Guix system ARCH name the SRCARCH name, which is set in the
+toplevel Makefile of Linux and denotes the architecture specific directory name
+below arch/ in its source code.  Some few architectures share a common folder.
+It resembles the definition of SRCARCH based on ARCH in the Makefile and may
+be used to place a defconfig file in the proper path."
+  (let ((linux-arch (system->linux-architecture arch)))
+    (match linux-arch
+      ("i386"    "x86")
+      ("x86_64"  "x86")
+      ("sparc32" "sparc")
+      ("sparc64" "sparc")
+      ("sh64"    "sh")
+      (_         linux-arch))))
+
 (define-public (system->defconfig system)
   "Some systems (notably powerpc-linux) require a special target for kernel
 defconfig.  Return the appropriate make target if applicable, otherwise return
@@ -820,8 +837,8 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration."
              (substitute* (find-files "." "^Makefile(\\.include)?$")
                (("/bin/pwd") "pwd"))
              #t))
-         (replace 'configure
-           (lambda* (#:key inputs native-inputs target #:allow-other-keys)
+         (add-before 'configure 'set-environment
+           (lambda* (#:key target #:allow-other-keys)
              ;; Avoid introducing timestamps
              (setenv "KCONFIG_NOTIMESTAMP" "1")
              (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
@@ -840,7 +857,9 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration."
 
              (setenv "EXTRAVERSION" ,(and extra-version
                                           (string-append "-" extra-version)))
-
+             #t))
+         (replace 'configure
+           (lambda* (#:key inputs native-inputs #:allow-other-keys)
              (let ((build  (assoc-ref %standard-phases 'build))
                    (config (assoc-ref (or native-inputs inputs) "kconfig")))
 
@@ -1155,6 +1174,111 @@ It has been modified to remove all non-free binary blobs.")
       (inherit base-linux-libre)
       (inputs `(("cpio" ,cpio) ,@(package-inputs base-linux-libre))))))
 
+
+;;;
+;;; Linux kernel customization functions.
+;;;
+
+(define*-public (modify-linux #:key name
+                                    (linux linux-libre)
+                                    source
+                                    defconfig
+                                    (configs "")
+                                    extra-version)
+  "Make a Linux package NAME as a modification of another LINUX package.
+
+If NAME is not given, then it defaults to the same name as the LINUX package.
+
+Unless SOURCE is given the source of LINUX is used.
+
+A DEFCONFIG file to be used can be given as a package, as a file like object
+(file-append, local-file etc.), or as a string with the name of a defconfig file
+available in the Linux sources.  If DEFCONFIG is not given, then a defconfig
+file will be saved from the LINUX package configuration.
+
+Additional CONFIGS will be used to modify the given or saved defconfig, which
+will finally be used to build Linux.
+
+CONFIGS can be a list of strings, with one configuration per line.  The usual
+defconfig syntax has to be used, but there is a special extension to ease the
+removal of configurations.  Comment lines are supported as well.
+
+Here is an explaining usage example:
+
+  '(;; This string defines the version tail in 'uname -r'.
+    \"CONFIG_LOCALVERSION=\\\"-handcrafted\\\"
+    ;; This '# CONFIG_… is not set' syntax has to match exactly!
+    \"# CONFIG_BOOT_CONFIG is not set\"
+    \"CONFIG_NFS_SWAP=y\"
+    ;; This is a multiline configuration:
+    \"CONFIG_E1000=y
+# This is a comment, below follow two special removal extensions:
+CONFIG_CMDLINE_EXTEND
+CONFIG_CMDLINE_FORCE=\")
+
+A string of configurations instead of a list of configuration strings is also
+possible.
+
+EXTRA-VERSION can be a string overwriting the EXTRAVERSION setting of the LINUX
+package, after being prepended by a hyphen.  It will be visible in the output
+of 'uname -r' behind the Linux version numbers."
+  (package
+    (inherit linux)
+    (name (or name (package-name linux)))
+    (source (or source (package-source linux)))
+    (arguments
+     (substitute-keyword-arguments
+         (package-arguments linux)
+       ((#:imported-modules imported-modules %gnu-build-system-modules)
+        `((guix build kconfig) ,@imported-modules))
+       ((#:modules modules)
+        `((guix build kconfig) ,@modules))
+       ((#:phases phases)
+        `(modify-phases ,phases
+           (replace 'configure
+             (lambda* (#:key inputs #:allow-other-keys #:rest arguments)
+               (let* ((srcarch
+                       ,(system->linux-srcarch (or (%current-target-system)
+                                                   (%current-system))))
+                      (configs (string-append "arch/" srcarch "/configs/"))
+                      (guix_defconfig (string-append configs "guix_defconfig")))
+                 ,(cond
+                    ((not defconfig)
+                      `(begin
+                         ;; Call the original 'configure phase.
+                         (apply (assoc-ref ,phases 'configure) arguments)
+                         ;; Save a defconfig file.
+                         (invoke "make" "savedefconfig")
+                         ;; Move the saved defconfig to the proper location.
+                         (rename-file "defconfig"
+                                      guix_defconfig)))
+                    ((string? defconfig)
+                      ;; Use another existing defconfig from the Linux sources.
+                      `(rename-file (string-append configs ,defconfig)
+                                    guix_defconfig))
+                    (else
+                      ;; Copy the defconfig input to the proper location.
+                      '(copy-file (assoc-ref inputs "guix_defconfig")
+                                  guix_defconfig)))
+                 (modify-defconfig guix_defconfig ',configs)
+                 ,@(if extra-version
+                      `((setenv "EXTRAVERSION"
+                                (string-append "-" extra-version)))
+                      '())
+                 (invoke "make" "guix_defconfig"))
+               #t))))))
+    (native-inputs
+      (append (if (or (not defconfig)
+                      (string? defconfig))
+                  '()
+                  ;; The defconfig should be a package or file-like object.
+                  `(("guix_defconfig" ,defconfig)))
+              (package-native-inputs linux)))))
+
+(define-public (make-defconfig uri sha256-as-base32)
+  (origin (method url-fetch)
+          (uri uri)
+          (sha256 (base32 sha256-as-base32))))
 
 
 ;;;
