04/11: ci: Add extra jobs for tunable packages.

[guix-commits]

civodul pushed a commit to branch wip-cpu-tuning
in repository guix.

commit 84fb7103c502ad18a6b1b6425911474303b10beb
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Dec 4 19:01:14 2021 +0100

    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 e101135..2f56554 100644
--- a/gnu/ci.scm
+++ b/gnu/ci.scm
@@ -28,6 +28,7 @@
   #: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)
@@ -108,9 +109,9 @@ building the derivation."
     (#: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 @@ otherwise use the IMAGE name."
                            (((_ 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 @@ names."
          ('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.