[bug#52283] [PATCH 01/10] Add (guix cpu).

[Ludovic Courtès]

* guix/cpu.scm: New file.
* Makefile.am (MODULES): Add it.
---
 Makefile.am  |   1 +
 guix/cpu.scm | 137 +++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 138 insertions(+)
 create mode 100644 guix/cpu.scm

diff --git a/Makefile.am b/Makefile.am
index f7e7b5184f..0846818cc2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -81,6 +81,7 @@ MODULES =                                     \
   guix/base64.scm                              \
   guix/ci.scm                                  \
   guix/cpio.scm                                        \
+  guix/cpu.scm                                 \
   guix/deprecation.scm                         \
   guix/docker.scm                              \
   guix/records.scm                             \
diff --git a/guix/cpu.scm b/guix/cpu.scm
new file mode 100644
index 0000000000..77efac92a2
--- /dev/null
+++ b/guix/cpu.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Ludovic Courtès <ludo@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 (guix cpu)
+  #:use-module (guix sets)
+  #:use-module (guix memoization)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:export (current-cpu
+            cpu?
+            cpu-architecture
+            cpu-family
+            cpu-model
+            cpu-flags
+
+            cpu->gcc-architecture))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to determine the micro-architecture supported
+;;; by the CPU and to map it to a name known to GCC's '-march'.
+;;;
+;;; Code:
+
+;; CPU description.
+(define-record-type <cpu>
+  (cpu architecture family model flags)
+  cpu?
+  (architecture cpu-architecture)                 ;string, from 'uname'
+  (family       cpu-family)                       ;integer
+  (model        cpu-model)                        ;integer
+  (flags        cpu-flags))                       ;set of strings
+
+(define current-cpu
+  (mlambda ()
+    "Return a <cpu> record representing the host CPU."
+    (define (prefix? prefix)
+      (lambda (str)
+        (string-prefix? prefix str)))
+
+    (call-with-input-file "/proc/cpuinfo"
+      (lambda (port)
+        (let loop ((family #f)
+                   (model #f))
+          (match (read-line port)
+            ((? eof-object?)
+             #f)
+            ((? (prefix? "cpu family") str)
+             (match (string-tokenize str)
+               (("cpu" "family" ":" family)
+                (loop (string->number family) model))))
+            ((? (prefix? "model") str)
+             (match (string-tokenize str)
+               (("model" ":" model)
+                (loop family (string->number model)))
+               (_
+                (loop family model))))
+            ((? (prefix? "flags") str)
+             (match (string-tokenize str)
+               (("flags" ":" flags ...)
+                (cpu (utsname:machine (uname))
+                     family model (list->set flags)))))
+            (_
+             (loop family model))))))))
+
+(define (cpu->gcc-architecture cpu)
+  "Return the architecture name, suitable for GCC's '-march' flag, that
+corresponds to CPU, a record as returned by 'current-cpu'."
+  (match (cpu-architecture cpu)
+    ("x86_64"
+     ;; Transcribed from GCC's 'host_detect_local_cpu' in driver-i386.c.
+     (or (and (= 6 (cpu-family cpu))              ;the "Pentium Pro" family
+              (letrec-syntax ((model (syntax-rules (=>)
+                                       ((_) #f)
+                                       ((_ (candidate => integers ...) rest
+                                           ...)
+                                        (or (and (= (cpu-model cpu) integers)
+                                                 candidate)
+                                            ...
+                                            (model rest ...))))))
+                (model ("bonnel" => #x1c #x26)
+                       ("silvermont" => #x37 #x4a #x4d #x5a #x5d)
+                       ("core2" => #x0f #x17 #x1d)
+                       ("nehalem" => #x1a #x1e #x1f #x2e)
+                       ("westmere" => #x25 #x2c #x2f)
+                       ("sandybridge" => #x2a #x2d)
+                       ("ivybridge" => #x3a #x3e)
+                       ("haswell" => #x3c #x3f #x45 #x46)
+                       ("broadwell" => #x3d #x47 #x4f #x56)
+                       ("skylake" => #x4e #x5e #x8e #x9e)
+                       ("skylake-avx512" => #x55) ;TODO: cascadelake
+                       ("knl" => #x57)
+                       ("cannonlake" => #x66)
+                       ("knm" => #x85))))
+
+         ;; Fallback case for non-Intel processors or for Intel processors not
+         ;; recognized above.
+         (letrec-syntax ((if-flags (syntax-rules (=>)
+                                     ((_)
+                                      #f)
+                                     ((_ (flags ... => name) rest ...)
+                                      (if (every (lambda (flag)
+                                                   (set-contains? (cpu-flags 
cpu)
+                                                                  flag))
+                                                 '(flags ...))
+                                          name
+                                          (if-flags rest ...))))))
+           (if-flags ("avx512" => "knl")
+                     ("adx" => "broadwell")
+                     ("avx2" => "haswell")
+                     ;; TODO: tigerlake, cooperlake, etc.
+                     ("avx" => "sandybridge")
+                     ("sse4_2" "movbe" => "silvermont")
+                     ("sse4_2" => "nehalem")
+                     ("ssse3" "movbe" => "bonnell")
+                     ("ssse3" => "core2")))
+         "x86_64"))
+    (architecture
+     ;; TODO: AArch64.
+     architecture)))
-- 
2.33.0