[bug#45020] [PATCH 0/2] image: Add system field.

[Mathieu Othacehe <othacehe@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 252 bytes --]


Hey,

Here's a patchset based on Ludo suggestion of introduction a platform
record. It is for now limited to system, target, and linux-architecture
fields but we could extend it to add the kernel, gcc, ... fields when
needed.

WDYT?

Thanks,

Mathieu

[-- Attachment #2: 0001-gnu-Add-platform-support.patch --]
[-- Type: text/x-patch, Size: 5859 bytes --]

From 711861495093a3b52aaf5469faf7f4820dfaa911 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Mon, 30 Aug 2021 17:46:05 +0200
Subject: [PATCH 1/2] gnu: Add platform support.

* gnu/platform.scm: New file.
* gnu/platforms/arm.scm: Ditto.
* gnu/platforms/hurd.scm: Ditto.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add them.
---
 gnu/local.mk           |  4 ++++
 gnu/platform.scm       | 38 ++++++++++++++++++++++++++++++++++++++
 gnu/platforms/arm.scm  | 36 ++++++++++++++++++++++++++++++++++++
 gnu/platforms/hurd.scm | 28 ++++++++++++++++++++++++++++
 4 files changed, 106 insertions(+)
 create mode 100644 gnu/platform.scm
 create mode 100644 gnu/platforms/arm.scm
 create mode 100644 gnu/platforms/hurd.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 5e4d9518bf..4c2efdf504 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -73,6 +73,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/bootloader/depthcharge.scm                \
   %D%/ci.scm					\
   %D%/image.scm					\
+  %D%/platform.scm				\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
   %D%/packages/abiword.scm			\
@@ -601,6 +602,9 @@ GNU_SYSTEM_MODULES =				\
   %D%/packages/zile.scm				\
   %D%/packages/zwave.scm			\
 						\
+  %D%/platforms/arm.scm		                \
+  %D%/platforms/hurd.scm	                \
+						\
   %D%/services.scm				\
   %D%/services/admin.scm			\
   %D%/services/audio.scm                        \
diff --git a/gnu/platform.scm b/gnu/platform.scm
new file mode 100644
index 0000000000..bb6519c71a
--- /dev/null
+++ b/gnu/platform.scm
@@ -0,0 +1,38 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu platform)
+  #:use-module (guix records)
+  #:export (platform
+            platform?
+            platform-target
+            platform-system
+            platform-linux-architecture))
+
+\f
+;;;
+;;; Platform record.
+;;;
+
+;; Description of a platform supported by the GNU system.
+(define-record-type* <platform> platform make-platform
+  platform?
+  (target             platform-target)               ;"x86_64-linux-gnu"
+  (system             platform-system)               ;"x86_64-linux"
+  (linux-architecture platform-linux-architecture    ;"amd64"
+                      (default #f)))
diff --git a/gnu/platforms/arm.scm b/gnu/platforms/arm.scm
new file mode 100644
index 0000000000..1e61741a35
--- /dev/null
+++ b/gnu/platforms/arm.scm
@@ -0,0 +1,36 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu platforms arm)
+  #:use-module (gnu platform)
+  #:use-module (gnu packages linux)
+  #:use-module (guix records)
+  #:export (armv7-linux
+            aarch64-linux))
+
+(define armv7-linux
+  (platform
+   (target "arm-linux-gnueabihf")
+   (system "armhf-linux")
+   (linux-architecture "arm")))
+
+(define aarch64-linux
+  (platform
+   (target "aarch64-linux-gnu")
+   (system "aarch64-linux")
+   (linux-architecture "arm64")))
diff --git a/gnu/platforms/hurd.scm b/gnu/platforms/hurd.scm
new file mode 100644
index 0000000000..0e5c58fd08
--- /dev/null
+++ b/gnu/platforms/hurd.scm
@@ -0,0 +1,28 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu platforms hurd)
+  #:use-module (gnu platform)
+  #:use-module (gnu packages linux)
+  #:use-module (guix records)
+  #:export (hurd))
+
+(define hurd
+  (platform
+   (target "i586-pc-gnu")
+   (system "i586-gnu")))
-- 
2.32.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-image-Add-platform-field.patch --]
[-- Type: text/x-patch, Size: 13302 bytes --]

From 8a5c6d75cb2bd9c26ec535229b52a2ab1b86c4b4 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Mon, 30 Aug 2021 17:48:10 +0200
Subject: [PATCH 2/2] image: Add platform field.

Fixes: <https://issues.guix.gnu.org/48327>.

* gnu/image.scm (<image>)[target]: Remove this field and replace it with ...
[platform]: ... this new field.
image-target): Remove it.
(image-platform, os+platform->image): New procedures.
* gnu/system/image.scm (arm32-disk-image, arm64-disk-image, arm32-image-type,
arm64-image-type): Remove them.
(raw-with-offset-disk-image, raw-with-offset-image-type): New procedures.
(system-image): Adapt it to use the image platform field.
* gnu/system/images/hurd.scm (hurd-disk-image): Remove the target field.
(hurd-barebones-disk-image, hurd-barebones-qcow2-image): Use
os+platform->image procedure.
* gnu/system/images/novena.scm (novena-image-type,
novena-barebones-raw-image): Use the os+platform->image.
* gnu/system/images/pine64.scm (pine64-image-type,
pine64-barebones-raw-image): Use the os+platform->image.
* gnu/system/images/pinebook-pro.scm (pinebook-pro-image-type,
pinebook-pro-barebones-raw-image): Use the os+platform->image.
* gnu/system/images/rock64.scm (rock64-image-type,
rock64-barebones-raw-image): Use the os+platform->image.
* guix/scripts/system.scm (process-action): Use the image platform field.
---
 gnu/image.scm                      | 13 ++++++--
 gnu/system/image.scm               | 51 ++++++++++++++++++------------
 gnu/system/images/hurd.scm         |  8 +++--
 gnu/system/images/novena.scm       |  6 ++--
 gnu/system/images/pine64.scm       |  6 ++--
 gnu/system/images/pinebook-pro.scm |  6 ++--
 gnu/system/images/rock64.scm       |  8 +++--
 guix/scripts/system.scm            |  5 ++-
 8 files changed, 66 insertions(+), 37 deletions(-)

diff --git a/gnu/image.scm b/gnu/image.scm
index 75d489490d..2381efa208 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu image)
+  #:use-module (gnu platform)
   #:use-module (guix records)
   #:export (partition
             partition?
@@ -34,7 +35,7 @@
             image?
             image-name
             image-format
-            image-target
+            image-platform
             image-size
             image-operating-system
             image-partitions
@@ -47,7 +48,8 @@
             image-type-name
             image-type-constructor
 
-            os->image))
+            os->image
+            os+platform->image))
 
 \f
 ;;;
@@ -78,7 +80,7 @@
   (name               image-name ;symbol
                       (default #f))
   (format             image-format) ;symbol
-  (target             image-target
+  (platform           image-platform ;<platform>
                       (default #f))
   (size               image-size  ;size in bytes as integer
                       (default 'guess))
@@ -112,3 +114,8 @@
 (define* (os->image os #:key type)
   (let ((constructor (image-type-constructor type)))
     (constructor os)))
+
+(define* (os+platform->image os platform #:key type)
+  (image
+   (inherit (os->image os #:type type))
+   (platform platform)))
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 1012fa6158..7a807b8226 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -31,6 +31,7 @@
   #:use-module (gnu bootloader)
   #:use-module (gnu bootloader grub)
   #:use-module (gnu image)
+  #:use-module (gnu platform)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu system)
@@ -66,16 +67,14 @@
 
             efi-disk-image
             iso9660-image
-            arm32-disk-image
-            arm64-disk-image
+            raw-with-offset-disk-image
 
             image-with-os
             efi-raw-image-type
             qcow2-image-type
             iso-image-type
             uncompressed-iso-image-type
-            arm32-image-type
-            arm64-image-type
+            raw-with-offset-image-type
 
             image-with-label
             system-image
@@ -128,10 +127,9 @@
            (label "GUIX_IMAGE")
            (flags '(boot)))))))
 
-(define* (arm32-disk-image #:optional (offset root-offset))
+(define* (raw-with-offset-disk-image #:optional (offset root-offset))
   (image
    (format 'disk-image)
-   (target "arm-linux-gnueabihf")
    (partitions
     (list (partition
            (inherit root-partition)
@@ -140,11 +138,6 @@
    ;; fails.
    (volatile-root? #f)))
 
-(define* (arm64-disk-image #:optional (offset root-offset))
-  (image
-   (inherit (arm32-disk-image offset))
-   (target "aarch64-linux-gnu")))
-
 \f
 ;;;
 ;;; Images types.
@@ -186,15 +179,10 @@ set to the given OS."
                   (compression? #f))
                  <>))))
 
-(define arm32-image-type
-  (image-type
-   (name 'arm32-raw)
-   (constructor (cut image-with-os (arm32-disk-image) <>))))
-
-(define arm64-image-type
+(define raw-with-offset-image-type
   (image-type
-   (name 'arm64-raw)
-   (constructor (cut image-with-os (arm64-disk-image) <>))))
+   (name 'raw-with-offset)
+   (constructor (cut image-with-os (raw-with-offset-disk-image) <>))))
 
 \f
 ;;
@@ -615,7 +603,30 @@ it can be used for bootloading."
   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 image, depending on IMAGE format."
   (define substitutable? (image-substitutable? image))
-  (define target (image-target image))
+  (define platform (image-platform image))
+
+  ;; The image platform definition may provide the appropriate "system"
+  ;; architecture for the image.  If we are already running on this system,
+  ;; the image can be built natively.  If we are running on a different
+  ;; system, then we need to cross-compile, using the "target" provided by the
+  ;; image definition.
+  (define system (and=> platform platform-system))
+  (define target (cond
+                  ;; No defined platform, let's use the user defined
+                  ;; system/target parameters.
+                  ((not platform)
+                   (%current-target-system))
+                  ;; The current system is the same as the platform system, no
+                  ;; need to cross-compile.
+                  ((and system
+                        (string=? system (%current-system)))
+                   #f)
+                  ;; If there is a user defined target let's override the
+                  ;; platform target. Otherwise, we can cross-compile to the
+                  ;; platform target.
+                  (else
+                   (or (%current-target-system)
+                       (and=> platform platform-target)))))
 
   (with-parameters ((%current-target-system target))
     (let* ((os (operating-system-for-image image))
diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm
index fc2dbe3209..77f7ff5e2b 100644
--- a/gnu/system/images/hurd.scm
+++ b/gnu/system/images/hurd.scm
@@ -23,6 +23,7 @@
   #:use-module (gnu bootloader grub)
   #:use-module (gnu image)
   #:use-module (gnu packages ssh)
+  #:use-module (gnu platforms hurd)
   #:use-module (gnu services)
   #:use-module (gnu services ssh)
   #:use-module (gnu system)
@@ -75,7 +76,6 @@
 (define hurd-disk-image
   (image
    (format 'disk-image)
-   (target "i586-pc-gnu")
    (partitions
     (list (partition
            (size 'guess)
@@ -103,13 +103,15 @@
 (define hurd-barebones-disk-image
   (image
    (inherit
-    (os->image hurd-barebones-os #:type hurd-image-type))
+    (os+platform->image hurd-barebones-os hurd
+                        #:type hurd-image-type))
    (name 'hurd-barebones-disk-image)))
 
 (define hurd-barebones-qcow2-image
   (image
    (inherit
-    (os->image hurd-barebones-os #:type hurd-qcow2-image-type))
+    (os+platform->image hurd-barebones-os hurd
+                        #:type hurd-qcow2-image-type))
    (name 'hurd-barebones.qcow2)))
 
 ;; Return the default image.
diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm
index 63227af509..3ce62fbf3b 100644
--- a/gnu/system/images/novena.scm
+++ b/gnu/system/images/novena.scm
@@ -22,6 +22,7 @@
   #:use-module (gnu bootloader u-boot)
   #:use-module (gnu image)
   #:use-module (gnu packages linux)
+  #:use-module (gnu platforms arm)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu system)
@@ -52,12 +53,13 @@
 (define novena-image-type
   (image-type
    (name 'novena-raw)
-   (constructor (cut image-with-os (arm32-disk-image) <>))))
+   (constructor (cut image-with-os (raw-with-offset-disk-image) <>))))
 
 (define novena-barebones-raw-image
   (image
    (inherit
-    (os->image novena-barebones-os #:type novena-image-type))
+    (os+platform->image novena-barebones-os armv7-linux
+                        #:type novena-image-type))
    (name 'novena-barebones-raw-image)))
 
 ;; Return the default image.
diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm
index 808c71295f..aaec458766 100644
--- a/gnu/system/images/pine64.scm
+++ b/gnu/system/images/pine64.scm
@@ -21,6 +21,7 @@
   #:use-module (gnu bootloader u-boot)
   #:use-module (gnu image)
   #:use-module (gnu packages linux)
+  #:use-module (gnu platforms arm)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu system)
@@ -57,12 +58,13 @@
 (define pine64-image-type
   (image-type
    (name 'pine64-raw)
-   (constructor (cut image-with-os (arm64-disk-image) <>))))
+   (constructor (cut image-with-os (raw-with-offset-disk-image) <>))))
 
 (define pine64-barebones-raw-image
   (image
    (inherit
-    (os->image pine64-barebones-os #:type pine64-image-type))
+    (os+platform->image pine64-barebones-os aarch64-linux
+                        #:type pine64-image-type))
    (name 'pine64-barebones-raw-image)))
 
 ;; Return the default image.
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
index b6b844cef6..1bfac7a8bb 100644
--- a/gnu/system/images/pinebook-pro.scm
+++ b/gnu/system/images/pinebook-pro.scm
@@ -21,6 +21,7 @@
   #:use-module (gnu bootloader u-boot)
   #:use-module (gnu image)
   #:use-module (gnu packages linux)
+  #:use-module (gnu platforms arm)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu system)
@@ -58,13 +59,14 @@
   (image-type
    (name 'pinebook-pro-raw)
    (constructor (cut image-with-os
-                     (arm64-disk-image (* 9 (expt 2 20))) ;9MiB
+                     (raw-with-offset-disk-image (* 9 (expt 2 20))) ;9MiB
                      <>))))
 
 (define pinebook-pro-barebones-raw-image
   (image
    (inherit
-    (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
+    (os+platform->image pinebook-pro-barebones-os aarch64-linux
+                        #:type pinebook-pro-image-type))
    (name 'pinebook-pro-barebones-raw-image)))
 
 ;; Return the default image.
diff --git a/gnu/system/images/rock64.scm b/gnu/system/images/rock64.scm
index 68d3742adc..d25d55e528 100644
--- a/gnu/system/images/rock64.scm
+++ b/gnu/system/images/rock64.scm
@@ -21,6 +21,7 @@
   #:use-module (gnu bootloader u-boot)
   #:use-module (gnu image)
   #:use-module (gnu packages linux)
+  #:use-module (gnu platforms arm)
   #:use-module (gnu services)
   #:use-module (gnu services base)
   #:use-module (gnu services networking)
@@ -53,12 +54,15 @@
 (define rock64-image-type
   (image-type
    (name 'rock64-raw)
-   (constructor (cut image-with-os (arm64-disk-image (expt 2 24)) <>))))
+   (constructor (cut image-with-os
+                     (raw-with-offset-disk-image (expt 2 24))
+                     <>))))
 
 (define rock64-barebones-raw-image
   (image
    (inherit
-    (os->image rock64-barebones-os #:type rock64-image-type))
+    (os+platform->image rock64-barebones-os aarch64-linux
+                        #:type rock64-image-type))
    (name 'rock64-barebones-raw-image)))
 
 rock64-barebones-raw-image
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 83bbefd3dc..a98a97e121 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -63,6 +63,7 @@
                  (device-module-aliases matching-modules)
   #:use-module (gnu system linux-initrd)
   #:use-module (gnu image)
+  #:use-module (gnu platform)
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
@@ -1204,13 +1205,11 @@ resulting from command-line parsing."
                             (base-image (if (operating-system? obj)
                                             (os->image obj
                                                        #:type image-type)
-                                            obj))
-                            (base-target (image-target base-image)))
+                                            obj)))
                         (image
                          (inherit (if label
                                       (image-with-label base-image label)
                                       base-image))
-                         (target (or base-target target))
                          (size image-size)
                          (volatile-root? volatile?))))
          (os          (image-operating-system image))
-- 
2.32.0