transformations: Add '--tune'.

* guix/transformations.scm (tuning-compiler)
(tuned-package, tunable-package?, package-tuning)
(transform-package-tuning)
(build-system-with-tuning-compiler): New procedures.
(%transformations): Add 'tune'.
(%transformation-options): Add "--tune".
* tests/transformations.scm ("options->transformation, tune")
("options->transformations, tune, wrong micro-architecture"): New
tests.
* doc/guix.texi (Package Transformation Options): Document '--tune'.

3 files changed, 300 insertions, 0 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 354eead02b..b72a3d1263 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -11015,6 +11015,67 @@ 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 the underlying compiler,
+by default 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 built with @code{-march=@var{CPU}}; under the hood,
+the @option{-march} option is passed to the actual wrapper by a compiler
+wrapper.  Since the build machine may not be able to run code for the
+target CPU micro-architecture, the test suite is not run when building a
+tuned package.
+
+To reduce rebuilds to the minimum, tuned packages are @emph{grafted}
+onto packages that depend on them (@pxref{Security Updates, grafts}).
+Thus, using @option{--no-grafts} cancels 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..c43c00cdd3 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -18,9 +18,11 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix transformations)
+  #:use-module ((guix config) #:select (%system))
   #:use-module (guix i18n)
   #:use-module (guix store)
   #:use-module (guix packages)
+  #:use-module (guix build-system)
   #:use-module (guix profiles)
   #:use-module (guix diagnostics)
   #:autoload   (guix download) (download-to-store)
@@ -29,6 +31,7 @@
   #: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 +52,9 @@
   #:export (options->transformation
             manifest-entry-with-transformations
 
+            tunable-package?
+            tuned-package
+
             show-transformation-options-help
             %transformation-options))
 
@@ -419,6 +425,181 @@ the equal sign."
             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 (build-system-with-tuning-compiler bs micro-architecture)
+  "Return a variant of BS, a build system, that ensures that the compiler that
+BS uses (usually an implicit input) can generate code for MICRO-ARCHITECTURE,
+which names a specific CPU of the target architecture--e.g., when targeting
+86_64 MICRO-ARCHITECTURE might be \"skylake\".  If it does, return a build
+system that builds code for MICRO-ARCHITECTURE; otherwise raise an error."
+  (define %not-hyphen
+    (char-set-complement (char-set #\-)))
+
+  (define lower
+    (build-system-lower bs))
+
+  (define (lower* . args)
+    ;; The list of CPU names supported by the '-march' option of C/C++
+    ;; compilers is specific to each compiler and version thereof.  Rather
+    ;; than pass '-march=MICRO-ARCHITECTURE' as is to the compiler, possibly
+    ;; leading to an obscure build error, check whether the compiler is known
+    ;; to support MICRO-ARCHITECTURE.  If not, bail out.
+    (let* ((lowered      (apply lower args))
+           (architecture (match (string-tokenize (bag-system lowered)
+                                                 %not-hyphen)
+                           ((arch _ ...) arch)))
+           (compiler     (any (match-lambda
+                                ((label (? package? p) . _)
+                                 (and (assoc-ref (package-properties p)
+                                                 'compiler-cpu-architectures)
+                                      p))
+                                (_ #f))
+                              (bag-build-inputs lowered))))
+      (unless compiler
+        (raise (formatted-message
+                (G_ "failed to determine which compiler is used"))))
+
+      (let ((lst (assoc-ref (package-properties compiler)
+                            'compiler-cpu-architectures)))
+        (unless lst
+          (raise (formatted-message
+                  (G_ "failed to determine whether ~a supports ~a")
+                  (package-full-name compiler)
+                  micro-architecture)))
+        (unless (member micro-architecture
+                        (or (assoc-ref lst architecture) '()))
+          (raise (formatted-message
+                  (G_ "compiler ~a does not support micro-architecture ~a")
+                  (package-full-name compiler)
+                  micro-architecture))))
+
+      (bag
+        (inherit lowered)
+        (build-inputs
+         ;; Arrange so that the compiler wrapper comes first in $PATH.
+         `(("tuning-compiler" ,(tuning-compiler micro-architecture))
+           ,@(bag-build-inputs lowered))))))
+
+  (build-system
+    (inherit bs)
+    (lower lower*)))
+
+(define (tuned-package p micro-architecture)
+  "Return package P tuned for MICRO-ARCHITECTURE."
+  (package
+    (inherit p)
+    (build-system
+      (build-system-with-tuning-compiler (package-build-system p)
+                                         micro-architecture))
+    (arguments
+     ;; The machine building this package may or may not be able to run code
+     ;; for MICRO-ARCHITECTURE.  Because of that, skip tests; they are run for
+     ;; the "baseline" variant anyway.
+     (substitute-keyword-arguments (package-arguments p)
+       ((#:tests? _ #f) #f)))
+
+    (properties
+     `((cpu-tuning . ,micro-architecture)
+
+       ;; Remove the 'tunable?' property so that 'package-tuning' does not
+       ;; call 'tuned-package' again on this one.
+       ,@(alist-delete 'tunable? (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))
+                              (info (G_ "tuning ~a for CPU ~a~%")
+                                    (package-full-name p) micro-architecture)
+                              (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 _ ...)
+     (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 +782,7 @@ are replaced by their latest upstream version."
     (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 +822,28 @@ are replaced by their latest upstream version."
                   (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")
+                         (unless (string=? (or (assoc-ref result 'system)
+                                               (%current-system))
+                                           %system)
+                           (leave (G_ "\
+building for ~a instead of ~a, so tuning cannot be guessed~%")
+                                  (assoc-ref result 'system) %system))
+
+                         (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..8db85b4305 100644
--- a/tests/transformations.scm
+++ b/tests/transformations.scm
@@ -38,12 +38,14 @@
   #:use-module (guix utils)
   #:use-module (guix git)
   #:use-module (guix upstream)
+  #:use-module (guix diagnostics)
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
   #:use-module (gnu packages busybox)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64))
 
 
@@ -465,6 +467,39 @@
                    `((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-assert "options->transformations, tune, wrong micro-architecture"
+  (let ((p (dummy-package "tunable"
+             (properties '((tunable? . #t)))))
+        (t (options->transformation '((tune . "nonexistent-superfast")))))
+    ;; Because GCC used by P's build system does not support
+    ;; '-march=nonexistent-superfast', we should see an error when lowering
+    ;; the tuned package.
+    (guard (c ((formatted-message? c)
+               (member "nonexistent-superfast"
+                       (formatted-message-arguments c))))
+      (package->bag (t p))
+      #f)))
+
 (test-equal "options->transformation + package->manifest-entry"
   '((transformations . ((without-tests . "foo"))))
   (let* ((p (dummy-package "foo"))