[bug#52283] [PATCH 02/10] transformations: Add '--tune'.

[Ludovic Courtès]

From: Ludovic Courtès <ludovic.courtes@inria.fr>

* guix/transformations.scm (tuning-compiler)
(tuned-package, tunable-package?, package-tuning)
(transform-package-tuning): New procedures.
(%transformations): Add 'tune'.
(%transformation-options): Add "--tune".
* tests/transformations.scm ("options->transformation, tune"): New
test.
* doc/guix.texi (Package Transformation Options): Document '--tune'.
---
 doc/guix.texi             |  54 +++++++++++++++
 guix/transformations.scm  | 134 ++++++++++++++++++++++++++++++++++++++
 tests/transformations.scm |  20 ++++++
 3 files changed, 208 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index a675631b79..e3aca8fd3b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10906,6 +10906,60 @@ available options and a synopsis (these options are 
not shown in the
 
 @table @code
 
+@cindex performance, tuning code
+@cindex optimization, of package code
+@cindex tuning, of package code
+@cindex SIMD support
+@cindex tunable packages
+@cindex package multi-versioning
+@item --tune[=@var{cpu}]
+Use versions of the packages marked as ``tunable'' optimized for
+@var{cpu}.  When @var{cpu} is @code{native}, or when it is omitted, tune
+for the CPU on which the @command{guix} command is running.
+
+Valid @var{cpu} names are those recognized by GCC, the GNU Compiler
+Collection.  On x86_64 processors, this includes CPU names such as
+@code{nehalem}, @code{haswell}, and @code{skylake} (@pxref{x86 Options,
+@code{-march},, gcc, Using the GNU Compiler Collection (GCC)}).
+
+As new generations of CPUs come out, they augment the standard
+instruction set architecture (ISA) with additional instructions, in
+particular instructions for single-instruction/multiple-data (SIMD)
+parallel processing.  For example, while Core2 and Skylake CPUs both
+implement the x86_64 ISA, only the latter supports AVX2 SIMD
+instructions.
+
+The primary gain one can expect from @option{--tune} is for programs
+that can make use of those SIMD capabilities @emph{and} that do not
+already have a mechanism to select the right optimized code at run time.
+Packages that have the @code{tunable?} property set are considered
+@dfn{tunable packages} by the @option{--tune} option; a package
+definition with the property set looks like this:
+
+@lisp
+(package
+  (name "hello-simd")
+  ;; ...
+
+  ;; This package may benefit from SIMD extensions so
+  ;; mark it as "tunable".
+  (properties '((tunable? . #t))))
+@end lisp
+
+Other packages are not considered tunable.  This allows Guix to use
+generic binaries in the cases where tuning for a specific CPU is
+unlikely to provide any gain.
+
+Tuned packages are @emph{grafted} onto packages that depend on them
+(@pxref{Security Updates, grafts}).  Thus, using @option{--no-grafts}
+annihilates the effect of @option{--tune}.
+
+We call this technique @dfn{package multi-versioning}: several variants
+of tunable packages may be built, one for each CPU variant.  It is the
+coarse-grain counterpart of @dfn{function multi-versioning} as
+implemented by the GNU tool chain (@pxref{Function Multiversioning,,,
+gcc, Using the GNU Compiler Collection (GCC)}).
+
 @item --with-source=@var{source}
 @itemx --with-source=@var{package}=@var{source}
 @itemx --with-source=@var{package}@@@var{version}=@var{source}
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 5ae1977cb2..3be02179ef 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -29,6 +29,7 @@ (define-module (guix transformations)
   #:autoload   (guix upstream) (package-latest-release
                                 upstream-source-version
                                 upstream-source-signature-urls)
+  #:autoload   (guix cpu) (current-cpu cpu->gcc-architecture)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix gexp)
@@ -49,6 +50,9 @@ (define-module (guix transformations)
   #:export (options->transformation
             manifest-entry-with-transformations
 
+            tunable-package?
+            tuned-package
+
             show-transformation-options-help
             %transformation-options))
 
@@ -419,6 +423,120 @@ (define replacements
             obj)
         obj)))
 
+(define tuning-compiler
+  (mlambda (micro-architecture)
+    "Return a compiler wrapper that passes '-march=MICRO-ARCHITECTURE' to the
+actual compiler."
+    (define wrapper
+      #~(begin
+          (use-modules (ice-9 match))
+
+          (define* (search-next command
+                                #:optional
+                                (path (string-split (getenv "PATH")
+                                                    #\:)))
+            ;; Search the next COMMAND on PATH, a list of
+            ;; directories representing the executable search path.
+            (define this
+              (stat (car (command-line))))
+
+            (let loop ((path path))
+              (match path
+                (()
+                 (match command
+                   ("cc" (search-next "gcc"))
+                   (_ #f)))
+                ((directory rest ...)
+                 (let* ((file (string-append
+                               directory "/" command))
+                        (st   (stat file #f)))
+                   (if (and st (not (equal? this st)))
+                       file
+                       (loop rest)))))))
+
+          (match (command-line)
+            ((command arguments ...)
+             (match (search-next (basename command))
+               (#f (exit 127))
+               (next
+                (apply execl next
+                       (append (cons next arguments)
+                           (list (string-append "-march="
+                                                #$micro-architecture))))))))))
+
+    (define program
+      (program-file (string-append "tuning-compiler-wrapper-" 
micro-architecture)
+                    wrapper))
+
+    (computed-file (string-append "tuning-compiler-" micro-architecture)
+                   (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils))
+
+                         (define bin (string-append #$output "/bin"))
+                         (mkdir-p bin)
+
+                         (for-each (lambda (program)
+                                     (symlink #$program
+                                              (string-append bin "/" program)))
+                                   '("cc" "gcc" "clang" "g++" "c++" 
"clang++")))))))
+
+(define (tuned-package p micro-architecture)
+  "Return package P tuned for MICRO-ARCHITECTURE."
+  (define compiler
+    (tuning-compiler micro-architecture))
+
+  (package
+    (inherit p)
+    (native-inputs
+     ;; Arrange so that COMPILER comes first in $PATH.
+     `(("tuning-compiler" ,compiler)
+       ,@(package-native-inputs p)))
+    (arguments
+     (substitute-keyword-arguments (package-arguments p)
+       ((#:tests? _ #f) #f)))
+    (properties
+     `((cpu-tuning . ,micro-architecture)
+       ,@(package-properties p)))))
+
+(define (tunable-package? package)
+  "Return true if package PACKAGE is \"tunable\"--i.e., if tuning it for the
+host CPU is worthwhile."
+  (assq 'tunable? (package-properties package)))
+
+(define package-tuning
+  (mlambda (micro-architecture)
+    "Return a procedure that maps the given package to its counterpart tuned
+for MICRO-ARCHITECTURE, a string suitable for GCC's '-march'."
+    (define rewriting-property
+      (gensym " package-tuning"))
+
+    (package-mapping (lambda (p)
+                       (cond ((assq rewriting-property (package-properties p))
+                              p)
+                             ((assq 'tunable? (package-properties p))
+                              (package/inherit p
+                                (replacement (tuned-package p 
micro-architecture))
+                                (properties `((,rewriting-property . #t)
+                                              ,@(package-properties p)))))
+                             (else
+                              p)))
+                     (lambda (p)
+                       (assq rewriting-property (package-properties p)))
+                     #:deep? #t)))
+
+(define (transform-package-tuning micro-architectures)
+  "Return a procedure that, when "
+  (match micro-architectures
+    ((micro-architecture _ ...)
+     (info (G_ "tuning for CPU micro-architecture ~a~%")
+           micro-architecture)
+     (let ((rewrite (package-tuning micro-architecture)))
+       (lambda (obj)
+         (if (package? obj)
+             (rewrite obj)
+             obj))))))
+
 (define (transform-package-with-debug-info specs)
   "Return a procedure that, when passed a package, set its 'replacement' field
 to the same package but with #:strip-binaries? #f in its 'arguments' field."
@@ -601,6 +719,7 @@ (define %transformations
     (with-commit . ,transform-package-source-commit)
     (with-git-url . ,transform-package-source-git-url)
     (with-c-toolchain . ,transform-package-toolchain)
+    (tune . ,transform-package-tuning)
     (with-debug-info . ,transform-package-with-debug-info)
     (without-tests . ,transform-package-tests)
     (with-patch  . ,transform-package-patches)
@@ -640,6 +759,21 @@ (define %transformation-options
                   (parser 'with-git-url))
           (option '("with-c-toolchain") #t #f
                   (parser 'with-c-toolchain))
+          (option '("tune") #f #t
+                  (lambda (opt name arg result . rest)
+                    (define micro-architecture
+                      (match arg
+                        ((or #f "native")
+                         (cpu->gcc-architecture (current-cpu)))
+                        ("generic" #f)
+                        (_ arg)))
+
+                    (apply values
+                           (if micro-architecture
+                               (alist-cons 'tune micro-architecture
+                                           result)
+                               (alist-delete 'tune result))
+                           rest)))
           (option '("with-debug-info") #t #f
                   (parser 'with-debug-info))
           (option '("without-tests") #t #f
diff --git a/tests/transformations.scm b/tests/transformations.scm
index 09839dc1c5..760b523e6e 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -465,6 +465,26 @@ (define (package-name* obj)
                    `((with-latest . "foo")))))
           (package-version (t p)))))
 
+(test-equal "options->transformation, tune"
+  '(cpu-tuning . "superfast")
+  (let* ((p0 (dummy-package "p0"))
+         (p1 (dummy-package "p1"
+               (inputs `(("p0" ,p0)))
+               (properties '((tunable? . #t)))))
+         (p2 (dummy-package "p2"
+               (inputs `(("p1" ,p1)))))
+         (t  (options->transformation '((tune . "superfast"))))
+         (p3 (t p2)))
+    (and (not (package-replacement p3))
+         (match (package-inputs p3)
+           ((("p1" tuned))
+            (match (package-inputs tuned)
+              ((("p0" p0))
+               (and (not (package-replacement p0))
+                    (assq 'cpu-tuning
+                          (package-properties
+                           (package-replacement tuned)))))))))))
+
 (test-equal "options->transformation + package->manifest-entry"
   '((transformations . ((without-tests . "foo"))))
   (let* ((p (dummy-package "foo"))
-- 
2.33.0