From bcbe4a43c6f9bcd643f9bfa2c18f49776ec226d4 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 4 Dec 2021 19:01:14 +0100
Subject: ci: Add extra jobs for tunable packages.

This allows us to provide substitutes for tuned package variants.

* gnu/ci.scm (package-job): Add #:suffix and honor it.
(package->job): Add #:suffix and honor it.
(%x86-64-micro-architectures): New variable.
(tuned-package-jobs): New procedure.
(cuirass-jobs): Add jobs for tunable packages.
---
 gnu/ci.scm | 43 ++++++++++++++++++++++++++++++++++---------
 1 file changed, 34 insertions(+), 9 deletions(-)

diff --git a/gnu/ci.scm b/gnu/ci.scm
index 6039af8f07..35fd583f75 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -28,6 +28,7 @@ (define-module (gnu ci)
   #:use-module (guix grafts)
   #:use-module (guix profiles)
   #:use-module (guix packages)
+  #:autoload   (guix transformations) (tunable-package? tuned-package)
   #:use-module (guix channels)
   #:use-module (guix config)
   #:use-module (guix derivations)
@@ -107,9 +108,9 @@ (define* (derivation->job name drv
     (#:timeout . ,timeout)))
 
 (define* (package-job store job-name package system
-                      #:key cross? target)
+                      #:key cross? target (suffix ""))
   "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
-  (let ((job-name (string-append job-name "." system)))
+  (let ((job-name (string-append job-name "." system suffix)))
     (parameterize ((%graft? #f))
       (let* ((drv (if cross?
                       (package-cross-derivation store package target system
@@ -395,21 +396,39 @@ (define package->job
                            (((_ inputs _ ...) ...)
                             inputs))))
                       (%final-inputs)))))
-    (lambda (store package system)
+    (lambda* (store package system #:key (suffix ""))
       "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
-valid."
+valid.  Append SUFFIX to the job name."
       (cond ((member package base-packages)
              (package-job store (string-append "base." (job-name package))
-                          package system))
+                          package system #:suffix suffix))
             ((supported-package? package system)
              (let ((drv (package-derivation store package system
                                             #:graft? #f)))
                (and (substitutable-derivation? drv)
                     (package-job store (job-name package)
-                                 package system))))
+                                 package system #:suffix suffix))))
             (else
              #f)))))
 
+(define %x86-64-micro-architectures
+  ;; Micro-architectures for which we build tuned variants.
+  '("westmere" "ivybridge" "haswell" "skylake" "skylake-avx512"))
+
+(define (tuned-package-jobs store package system)
+  "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures."
+  (filter-map (lambda (micro-architecture)
+                (define suffix
+                  (string-append "." micro-architecture))
+
+                (package->job store
+                              (tuned-package package micro-architecture)
+                              system
+                              #:suffix suffix))
+              (match system
+                ("x86_64-linux" %x86-64-micro-architectures)
+                (_ '()))))
+
 (define (all-packages)
   "Return the list of packages to build."
   (define (adjust package result)
@@ -527,10 +546,16 @@ (define source
          ('all
           ;; Build everything, including replacements.
           (let ((all (all-packages))
-                (job (lambda (package)
-                       (package->job store package system))))
+                (jobs (lambda (package)
+                        (match (package->job store package system)
+                          (#f '())
+                          (main-job
+                           (cons main-job
+                                 (if (tunable-package? package)
+                                     (tuned-package-jobs store package system)
+                                     '())))))))
             (append
-             (filter-map job all)
+             (append-map jobs all)
              (cross-jobs store system))))
          ('core
           ;; Build core packages only.
-- 
cgit v1.2.3