Merge branch 'master' into gnome-team

8 files changed, 164 insertions, 94 deletions

diff --git a/guix/avahi.scm b/guix/avahi.scm
index cb0c85f9f4..574fe0b850 100644
--- a/guix/avahi.scm
+++ b/guix/avahi.scm
@@ -49,11 +49,17 @@
   (port avahi-service-port)
   (txt avahi-service-txt))
 
+(define never
+  ;; Never true.
+  (const #f))
+
 (define* (avahi-publish-service-thread name
                                        #:key
                                        type port
-                                       (stop-loop? (const #f))
-                                       (timeout 100)
+                                       (stop-loop? never)
+                                       (timeout (if (eq? stop-loop? never)
+                                                    #f
+                                                    500))
                                        (txt '()))
   "Publish the service TYPE using Avahi, for the given PORT, on all interfaces
 and for all protocols. Also, advertise the given TXT record list.
@@ -78,7 +84,9 @@ when STOP-LOOP? procedure returns true."
                                   client-flag/ignore-user-config)
                                  client-callback)))
        (while (not (stop-loop?))
-         (iterate-simple-poll poll timeout))))))
+         (if timeout
+             (iterate-simple-poll poll timeout)
+             (iterate-simple-poll poll)))))))
 
 (define (interface->ip-address interface)
   "Return the local IP address of the given INTERFACE."
@@ -89,10 +97,6 @@ when STOP-LOOP? procedure returns true."
     (close-port socket)
     ip))
 
-(define never
-  ;; Never true.
-  (const #f))
-
 (define* (avahi-browse-service-thread proc
                                       #:key
                                       types
@@ -101,7 +105,7 @@ when STOP-LOOP? procedure returns true."
                                       (stop-loop? never)
                                       (timeout (if (eq? stop-loop? never)
                                                    #f
-                                                   100)))
+                                                   500)))
   "Browse services which type is part of the TYPES list, using Avahi.  The
 search is restricted to services with the given FAMILY.  Each time a service
 is found or removed, PROC is called and passed as argument the corresponding
diff --git a/guix/build/git.scm b/guix/build/git.scm
index 669e38cd32..deda10fee8 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -52,7 +52,7 @@ recursively.  Return #t on success, #f otherwise."
              (delete-file-recursively directory)
              #f))
     (with-directory-excursion directory
-      (invoke git-command "init")
+      (invoke git-command "init" "--initial-branch=main")
       (invoke git-command "remote" "add" "origin" url)
       (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
           (invoke git-command "checkout" "FETCH_HEAD")
diff --git a/guix/cache.scm b/guix/cache.scm
index be0de90e67..6a91c7d3ef 100644
--- a/guix/cache.scm
+++ b/guix/cache.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2017, 2020-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -55,7 +55,7 @@
 time\" computed as its timestamp + TTL seconds.  Call TIMESTAMP to obtain the
 relevant timestamp from the result of 'stat'."
   (lambda (file)
-    (match (stat file #f)
+    (match (false-if-exception (lstat file))
       (#f 0)                       ;FILE may have been deleted in the meantime
       (st (+ (timestamp st) ttl)))))
 
diff --git a/guix/cpu.scm b/guix/cpu.scm
index 45e1abeed7..29ad883584 100644
--- a/guix/cpu.scm
+++ b/guix/cpu.scm
@@ -32,7 +32,8 @@
             cpu-model
             cpu-flags
 
-            cpu->gcc-architecture))
+            cpu->gcc-architecture
+            gcc-architecture->micro-architecture-level))
 
 ;;; Commentary:
 ;;;
@@ -114,19 +115,19 @@ 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.cc.
-     (or (and (equal? "GenuineIntel" (cpu-vendor cpu))
-              (= 6 (cpu-family cpu))              ;the "Pentium Pro" family
-              (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 ...))))))
+     (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 ...))))))
 
+       (or (and (equal? "GenuineIntel" (cpu-vendor cpu))
+                (= 6 (cpu-family cpu))              ;the "Pentium Pro" family
                 (if-flags ("avx" "raoint" => "grandridge")
                           ("avx" "amx_fp16" => "graniterapids")
                           ("avx" "avxvnniint8" => "sierraforest")
@@ -152,20 +153,9 @@ corresponds to CPU, a record as returned by 'current-cpu'."
                           ("ssse3" "movbe" => "bonnell")
                           ("ssse3" => "core2")
                           ("longmode" => "x86-64")
-                          ("lm" => "x86-64"))))
-
-         (and (equal? "AuthenticAMD" (cpu-vendor cpu))
-              (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 ...))))))
+                          ("lm" => "x86-64")))
 
+           (and (equal? "AuthenticAMD" (cpu-vendor cpu))
                 (or (and (= 22 (cpu-family cpu))
                          (if-flags ("movbe" => "btver2")))
                     (and (= 6 (cpu-family cpu))
@@ -192,42 +182,18 @@ corresponds to CPU, a record as returned by 'current-cpu'."
                               ("lm" => "k8")
                               ("mmx" "3dnow" => "k6-3")
                               ("mmx" => "k6")
-                              (_ => "pentium")))))
+                              (_ => "pentium"))))
 
-         ;; 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 ...))))))
+           ;; Fallback case for non-Intel processors or for processors not
+           ;; recognized above.
            (if (and (= 7 (cpu-family cpu))
                     (= #x3b (cpu-model cpu)))
              "lujiazui"
-             (if-flags ("avx512" => "knl")
-                       ("adx" => "broadwell")
-                       ("avx2" => "haswell")
-                       ;; TODO: tigerlake, cooperlake, etc.
-                       ("avx" => "sandybridge")
-                       ("sse4_2" "gfni" => "tremont")
-                       ("sse4_2" "sgx" => "goldmont-plus")
-                       ("sse4_2" "xsave" => "goldmont")
-                       ("sse4_2" "movbe" => "silvermont")
-                       ("sse4_2" => "nehalem")
-                       ("ssse3" "movbe" => "bonnell")
-                       ("ssse3" "sse3" "longmode" => "nocona")
-                       ("ssse3" "sse3" "lm" => "nocona")
-                       ("ssse3" "sse3" => "prescott")
-                       ("ssse3" => "core2"))))
+             (cpu->micro-architecture-level cpu))
 
          ;; TODO: Recognize CENTAUR/CYRIX/NSC?
 
-         "x86_64"))
+         "x86_64")))
     ("aarch64"
      ;; Transcribed from GCC's list of aarch64 processors in aarch64-cores.def
      ;; What to do with big.LITTLE cores?
@@ -285,3 +251,57 @@ corresponds to CPU, a record as returned by 'current-cpu'."
     (architecture
      ;; TODO: More architectures
      architecture)))
+
+(define (cpu->micro-architecture-level cpu)
+  "Return a micro-architecture name, suitable for generalized optimizations that
+correspond roughly to CPU, a record as returned by 'current-cpu'."
+  (match (cpu-architecture cpu)
+    ("x86_64"
+     (or (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
+             ;; https://gitlab.com/x86-psABIs/x86-64-ABI/-/blob/master/x86-64-ABI/low-level-sys-info.tex
+             ;; v4: AVX512F, AVX512BW, AVX512CD, AVX512DQ, AVX512VL
+             ;; v3: AVX, AVX2, BMI1, BMI2, F16C, FMA, LZCNT, MOVBE, OSXSAVE
+             ;; v2: CMPXCHG16B, LAHF, SAHF, POPCNT, SSE3, SSE4.1, SSE4.2, SSSE3
+             ("avx512f" "avx512bw" "abx512cd" "abx512dq" "avx512vl"
+              "avx" "avx2" "bmi1" "bmi2" "f16c" "fma" "movbe"
+              "popcnt" "sse3" "sse4_1" "sse4_2" "ssse3" => "x86_64-v4")
+             ("avx" "avx2" "bmi1" "bmi2" "f16c" "fma" "movbe"
+              "popcnt" "sse3" "sse4_1" "sse4_2" "ssse3" => "x86_64-v3")
+             ("popcnt" "sse3" "sse4_1" "sse4_2" "ssse3" => "x86_64-v2")
+             (_ => "x86_64-v1")))
+         "x86_64-v1"))
+    (architecture
+     ;; TODO: More architectures
+     architecture)))
+
+(define (gcc-architecture->micro-architecture-level gcc-architecture)
+  "Return a matching psABI micro-architecture, allowing optimizations for x86_64
+CPUs for compilers which don't allow for more focused optimizing."
+  ;; Matching gcc-architectures isn't an easy task, with the rule-of-thumb being
+  ;; 'Haswell and higher' qualify for x86_64-v3.
+  ;; https://gitlab.com/x86-psABIs/x86-64-ABI/-/blob/master/x86-64-ABI/low-level-sys-info.tex
+  (match gcc-architecture
+    ((or "grandridge" "graniterapids" "sierraforest" "tigerlake"
+         "sapphirerapids" "cooperlake" "icelake-server" "icelake-client"
+         "cannonlake" "knm" "knl" "skylake-avx512" "alderlake" "skylake"
+         "broadwell" "haswell"
+         "znver4" "znver3" "znver2" "znver1" "bdver4")
+     "x86_64-v3")
+    ((or "sandybridge" "tremont" "goldmont-plus" "goldmont" "silvermont"
+         "nehalem" "bonnell" "core2"
+         "btver2" "athalon" "k8-sse3" "k8" "bdver3" "bdver2" "bdver1" "btver1"
+         "amdfam10"
+         "lujiazui" "x86-64")
+     "x86_64-v1")
+    (_ gcc-architecture)))
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 18a1396cf5..59c65f9fa5 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -431,6 +431,7 @@ empty list when the FIELD cannot be found."
     ("whoami" "coreutils")
     ("x11" "libx11")
     ("xml2" "libxml2")
+    ("zlib-devel" "zlib")
     (_ sysname)))
 
 (define cran-guix-name (cut guix-name "r-" <>))
diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm
index aeaffa3d34..79af533fd9 100644
--- a/guix/scripts/locate.scm
+++ b/guix/scripts/locate.scm
@@ -418,19 +418,24 @@ for each package to insert."
       (()
        entries)
       ((profile . rest)
-       (let* ((manifest (profile-manifest profile))
-              (entries visited
-                       (fold2 (lambda (entry lst visited)
-                                (let ((item (manifest-entry-item entry)))
-                                  (if (set-contains? visited item)
-                                      (values lst visited)
-                                      (values (cons entry lst)
-                                              (set-insert item
-                                                          visited)))))
-                              entries
-                              visited
-                              (manifest-transitive-entries manifest))))
-         (loop visited rest entries))))))
+       (match (false-if-exception (profile-manifest profile))
+         (#f
+          ;; PROFILE's manifest is unreadable for some reason such as an
+          ;; unsupported version.
+          (loop visited rest entries))
+         (manifest
+          (let ((entries visited
+                         (fold2 (lambda (entry lst visited)
+                                  (let ((item (manifest-entry-item entry)))
+                                    (if (set-contains? visited item)
+                                        (values lst visited)
+                                        (values (cons entry lst)
+                                                (set-insert item
+                                                            visited)))))
+                                entries
+                                visited
+                                (manifest-transitive-entries manifest))))
+            (loop visited rest entries))))))))
 
 (define (insert-manifest-entry db entry)
   "Insert a manifest ENTRY into DB."
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 9676271542..f5cb18af22 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -6,7 +6,7 @@
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019, 2023 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -589,16 +589,27 @@ all are dependent packages: ~{~a~^ ~}~%")
                               (or (assoc-ref opts 'keyring)
                                   (string-append (config-directory)
                                                  "/upstream/trustedkeys.kbx"))))
-                (for-each
-                 (lambda (update)
-                   (update-package store
-                                   (update-spec-package update)
-                                   (update-spec-version update)
-                                   updaters
-                                   #:key-server (%openpgp-key-server)
-                                   #:key-download key-download
-                                   #:warn? warn?))
-                 update-specs)
+                (let* ((spec-line
+                        (compose location->string
+                                 package-location
+                                 update-spec-package))
+                       ;; Sort the specs so that we update packages from the
+                       ;; bottom of the file to the top.  This way we can be
+                       ;; sure that the package locations are always correct
+                       ;; and never shifted due to previous edits.
+                       (sorted-update-specs
+                        (sort update-specs
+                              (lambda (a b) (string> (spec-line a) (spec-line b))))))
+                  (for-each
+                   (lambda (update)
+                     (update-package store
+                                     (update-spec-package update)
+                                     (update-spec-version update)
+                                     updaters
+                                     #:key-server (%openpgp-key-server)
+                                     #:key-download key-download
+                                     #:warn? warn?))
+                   sorted-update-specs))
                 (return #t)))
              (else
               (for-each (cut check-for-package-update <> updaters
diff --git a/guix/transformations.scm b/guix/transformations.scm
index a289f81219..92d9c89c0e 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
+;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,7 +33,9 @@
   #:autoload   (guix upstream) (package-latest-release
                                 upstream-source-version
                                 upstream-source-signature-urls)
-  #:autoload   (guix cpu) (current-cpu cpu->gcc-architecture)
+  #:autoload   (guix cpu) (current-cpu
+                           cpu->gcc-architecture
+                           gcc-architecture->micro-architecture-level)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix gexp)
@@ -516,7 +519,9 @@ system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
                                                  'compiler-cpu-architectures)
                                       p))
                                 (_ #f))
-                              (bag-build-inputs lowered))))
+                              (bag-build-inputs lowered)))
+           (psabi        (gcc-architecture->micro-architecture-level
+                           micro-architecture)))
       (unless compiler
         (raise (formatted-message
                 (G_ "failed to determine which compiler is used"))))
@@ -528,8 +533,11 @@ system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
                   (G_ "failed to determine whether ~a supports ~a")
                   (package-full-name compiler)
                   micro-architecture)))
-        (unless (member micro-architecture
-                        (or (assoc-ref lst architecture) '()))
+        (unless (or (member micro-architecture
+                            (or (assoc-ref lst architecture) '()))
+                    (and (string=? (package-name compiler) "go")
+                         (member psabi
+                                 (or (assoc-ref lst architecture) '()))))
           (raise
            (make-compound-condition
             (formatted-message
@@ -556,6 +564,27 @@ micro-architectures:
 
       (bag
         (inherit lowered)
+        (arguments
+          (substitute-keyword-arguments (bag-arguments lowered)
+          ;; We add the tuning parameter after the default GO flags are set.
+          ((#:phases phases '%standard-phases)
+             #~(modify-phases #$phases
+                 (add-after 'setup-go-environment 'set-microarchitecture
+                   (lambda _
+                     (cond
+                       ((string-prefix? "arm" #$psabi)
+                        (setenv "GOARM" (string-take-right #$psabi 1))
+                        (format #t "Setting GOARM to ~s."
+                                (getenv "GOARM")))
+                       ((string-prefix? "powerpc" #$psabi)
+                        (setenv "GOPPC64" #$psabi)
+                        (format #t "Setting GOPPC64 to ~s."
+                                (getenv "GOPPC64")))
+                       ((string-prefix? "x86_64" #$psabi)
+                        (setenv "GOAMD" (string-take-right #$psabi 2))
+                        (format #t "Setting GOAMD to ~s.\n"
+                                (getenv "GOAMD")))
+                       (else #t))))))))
         (build-inputs
          ;; Arrange so that the compiler wrapper comes first in $PATH.
          `(("tuning-compiler" ,(tuning-compiler micro-architecture))