-
Ludovic Courtès authored
* function-multi-versioning.scm (fmv-patched-package): Remove 'package-with-c-toolchain' call.
Ludovic Courtès authored* function-multi-versioning.scm (fmv-patched-package): Remove 'package-with-c-toolchain' call.
function-multi-versioning.scm 10.80 KiB
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(use-modules (guix) (gnu)
(guix build-system)
(guix utils)
((gnu packages base) #:select (tar))
((gnu packages compression) #:select (gzip bzip2 xz))
((gnu packages code) #:select (global))
((gnu packages version-control) #:select (git-minimal)))
(define (package-build-log p)
"Return a package object that contains the build log of package P."
(package
(inherit p)
(name (string-append (package-full-name p "-")
"-vectorization-log"))
(outputs '("out"))
(arguments
(substitute-keyword-arguments (package-arguments p)
((#:out-of-source? _ #f)
;; Build out of source so warnings include absolute file names.
#t)
((#:make-flags flags ''())
`(append ,flags '("CFLAGS=-O3 -g0 -fopt-info-vec")))
((#:phases phases '%standard-phases)
`(modify-phases ,phases
(add-before 'build 'record-log
(lambda* (#:key outputs #:allow-other-keys)
;; Redirect stderr, which is where '-fopt-info-vec' goes, to
;; OUT.
(let ((out (assoc-ref outputs "out")))
(redirect-port (open-file out "w0")
(current-error-port))
#t)))
(add-after 'build 'stop
(lambda* (#:key outputs #:allow-other-keys)
(let ((log (assoc-ref outputs "out")))
;; Strip the leading "../" from source file names.
(substitute* log
(("^\\.\\./") ""))
;; Stop here!
(exit 0))))))))))
(define latest-toolchain
`(("gcc-toolchain"
,(specification->package "gcc-toolchain"))))
(define (build-log->location-sexps log)
"Parse LOG, a build log as returned by 'package-build-log', and produce a
file containing source code locations found in LOG formatted as an sexp along
these lines:
((FILE1 (LINE1 COLUMN1) (LINE2 COLUMN2) ...) (FILE2 (LINE1 COLUMN1) ...)
...)
"
(define build
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(srfi srfi-1)
(ice-9 rdelim)
(ice-9 pretty-print)
(ice-9 match)
(ice-9 vlist)
(ice-9 regex))
(define %opt-info-regexp
(make-regexp "^([^:]+):([[:digit:]]+):([[:digit:]]+): "))
(define (build-log->locations port)
;; Return the build log from PORT and return a location list.
(let loop ((result '()))
(match (read-line port)
((? eof-object?)
(delete-duplicates (reverse result)))
((? string? line)
(match (regexp-exec %opt-info-regexp line)
(#f
(loop result))
(m
(loop (cons (list (match:substring m 1)
(string->number
(match:substring m 2))
(string->number
(match:substring m 3)))
result))))))))
(define locations
(call-with-input-file #$log build-log->locations))
(define (grouped-by-file locations)
;; Given LOCATIONS, a list like ((FILE LINE COLUMN) ...), return
;; a list grouped by files: ((FILE (LINE COLUMN) ...) ...).
(define files
(match locations
(((files _ ...) ...) files)))
(define table
(fold (match-lambda*
(((file line column) table)
(vhash-cons file (list line column) table)))
vlist-null
locations))
(map (lambda (file)
(cons file
(reverse (vhash-fold* cons '() file table))))
(delete-duplicates files)))
(call-with-output-file #$output
(lambda (port)
(pretty-print (grouped-by-file locations) port))))))
(computed-file "location-sexps" build))
(define* (fmv-patch p #:key (toolchain latest-toolchain))
"Compute a function multi-versioning (FMV) patch for package P. Use
TOOLCHAIN to obtain vectorization info."
(define log
(package-build-log
(package-with-c-toolchain p latest-toolchain)))
(define candidates (build-log->location-sexps log))
(define build
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 ftw)
(ice-9 match)
(ice-9 rdelim)
(ice-9 regex)
(ice-9 popen))
(define %global-tag-line
;; Regexp matching the output of "global -d".
(make-regexp "^[[:graph:]]+ +([[:digit:]]+) .*$"))
(define (symbol-definition-locations file)
;; Return the list of "symbol" definition locations as a list of
;; 1-indexed line numbers. Symbols can be functions but
;; (unfortunately) they can also be enums, typedefs, etc.
(let ((pipe (open-pipe* OPEN_READ "global" "-fd" file)))
(let loop ((lines '()))
(define line
(read-line pipe))
(cond ((eof-object? line)
(unless (zero? (close-pipe pipe))
(error "global failed"))
(reverse lines))
((regexp-exec %global-tag-line line)
=>
(lambda (m)
(loop (cons (string->number (match:substring m 1))
lines))))
(else
(pk 'weird line)
(loop lines))))))
(define (nearest-symbol-definition line definitions)
(let loop ((definitions definitions)
(candidate #f))
(match definitions
((head . rest)
(loop rest (if (< head line) head candidate)))
(()
candidate))))
(define %function-prototype
;; Terrible hack to recognize things that vaguely resemble a
;; function prototype. The point here is to distinguish it from
;; a variable or enum value definition.
(make-regexp "[a-zA-Z_0-9]+[[:space:]]*\\("))
(define %fmv-attribute
"__attribute__ ((target_clones (\"avx2\", \"arch=skylake-avx512\", \
\"arch=atom\", \"default\")))\n")
(define (edit-functions file lines)
(with-fluids ((%default-port-encoding "ISO-8859-1"))
(call-with-input-file file
(lambda (input)
(call-with-output-file (string-append file ".tmp")
(lambda (output)
(let loop ((line-number 1))
(define line (read-line input 'concat))
(when (and (member line-number lines)
(not (eof-object? line)) (not (any (cute string-prefix? <>
(string-trim line))
'("#" "enum" "struct"
"typedef" "class")))
(regexp-exec %function-prototype line))
(display %fmv-attribute output))
(unless (eof-object? line)
(display line output)
(loop (+ 1 line-number))))))))
(rename-file (string-append file ".tmp") file)))
(define fmv-candidates
(call-with-input-file #$candidates read))
(setenv "PATH"
(string-join '(#+tar #+gzip #+bzip2 #+xz
#+git-minimal #+global)
"/bin:" 'suffix))
(invoke "tar" "xf" #+(package-source p))
(let ((source (match (scandir ".")
(("." ".." source) source))))
(chdir source)
(setenv "HOME" (getcwd))
(invoke "git" "config" "--global" "user.email" "guix@example.org")
(invoke "git" "init")
(invoke "git" "add" ".")
(invoke "git" "commit" "-m" "initial commit")
(invoke "gtags")
(for-each (match-lambda
((file (lines columns) ...)
(when (file-exists? file)
(let ((definitions
(symbol-definition-locations file)))
(edit-functions file
(map (lambda (line)
(pk 'nearest file line
(nearest-symbol-definition
line definitions)))
lines))))))
fmv-candidates)
(with-output-to-file #$output
(lambda ()
(invoke "git" "diff" "HEAD")))))))
(computed-file (string-append (package-full-name p "-")
"-fmv.patch")
build))
(define* (fmv-patched-package p #:key (toolchain latest-toolchain))
"Return package P patched to contain multi-versioned functions."
(package/inherit p
(source (origin
(inherit (package-source p))
(patches (cons (fmv-patch p #:toolchain toolchain)
(origin-patches (package-source p))))))))
;; Return the patched package.
(fmv-patched-package
(specification->package (or (getenv "GUIX_FMV_PACKAGE") "gsl")))