f4609b896f
This also bumps the stable nixpkgs to 20.09 as of 2020-11-21, because there is some breakage in the git build related to the netrc credentials helper which someone has taken care of in nixpkgs. The stable channel is not used for anything other than git, so this should be fine. Change-Id: I3575a19dab09e1e9556cf8231d717de9890484fb
356 lines
8.2 KiB
Perl
Executable file
356 lines
8.2 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
use lib '../../perl/build/lib';
|
|
use strict;
|
|
use warnings;
|
|
use Getopt::Long;
|
|
use Cwd qw(realpath);
|
|
|
|
sub get_times {
|
|
my $name = shift;
|
|
open my $fh, "<", $name or return undef;
|
|
my $line = <$fh>;
|
|
return undef if not defined $line;
|
|
close $fh or die "cannot close $name: $!";
|
|
# times
|
|
if ($line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/) {
|
|
my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
|
|
return ($rt, $4, $5);
|
|
# size
|
|
} elsif ($line =~ /^\d+$/) {
|
|
return $&;
|
|
} else {
|
|
die "bad input line: $line";
|
|
}
|
|
}
|
|
|
|
sub relative_change {
|
|
my ($r, $firstr) = @_;
|
|
if ($firstr > 0) {
|
|
return sprintf "%+.1f%%", 100.0*($r-$firstr)/$firstr;
|
|
} elsif ($r == 0) {
|
|
return "=";
|
|
} else {
|
|
return "+inf";
|
|
}
|
|
}
|
|
|
|
sub format_times {
|
|
my ($r, $u, $s, $firstr) = @_;
|
|
# no value means we did not finish the test
|
|
if (!defined $r) {
|
|
return "<missing>";
|
|
}
|
|
# a single value means we have a size, not times
|
|
if (!defined $u) {
|
|
return format_size($r, $firstr);
|
|
}
|
|
# otherwise, we have real/user/system times
|
|
my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
|
|
$out .= ' ' . relative_change($r, $firstr) if defined $firstr;
|
|
return $out;
|
|
}
|
|
|
|
sub usage {
|
|
print <<EOT;
|
|
./aggregate.perl [options] [--] [<dir_or_rev>...] [--] [<test_script>...] >
|
|
|
|
Options:
|
|
--codespeed * Format output for Codespeed
|
|
--reponame <str> * Send given reponame to codespeed
|
|
--sort-by <str> * Sort output (only "regression" criteria is supported)
|
|
--subsection <str> * Use results from given subsection
|
|
|
|
EOT
|
|
exit(1);
|
|
}
|
|
|
|
sub human_size {
|
|
my $n = shift;
|
|
my @units = ('', qw(K M G));
|
|
while ($n > 900 && @units > 1) {
|
|
$n /= 1000;
|
|
shift @units;
|
|
}
|
|
return $n unless length $units[0];
|
|
return sprintf '%.1f%s', $n, $units[0];
|
|
}
|
|
|
|
sub format_size {
|
|
my ($size, $first) = @_;
|
|
# match the width of a time: 0.00(0.00+0.00)
|
|
my $out = sprintf '%15s', human_size($size);
|
|
$out .= ' ' . relative_change($size, $first) if defined $first;
|
|
return $out;
|
|
}
|
|
|
|
sub sane_backticks {
|
|
open(my $fh, '-|', @_);
|
|
return <$fh>;
|
|
}
|
|
|
|
my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
|
|
$codespeed, $sortby, $subsection, $reponame);
|
|
|
|
Getopt::Long::Configure qw/ require_order /;
|
|
|
|
my $rc = GetOptions("codespeed" => \$codespeed,
|
|
"reponame=s" => \$reponame,
|
|
"sort-by=s" => \$sortby,
|
|
"subsection=s" => \$subsection);
|
|
usage() unless $rc;
|
|
|
|
while (scalar @ARGV) {
|
|
my $arg = $ARGV[0];
|
|
my $dir;
|
|
my $prefix = '';
|
|
last if -f $arg or $arg eq "--";
|
|
if (! -d $arg) {
|
|
my $rev = sane_backticks(qw(git rev-parse --verify), $arg);
|
|
chomp $rev;
|
|
$dir = "build/".$rev;
|
|
} elsif ($arg eq '.') {
|
|
$dir = '.';
|
|
} else {
|
|
$dir = realpath($arg);
|
|
$dirnames{$dir} = $dir;
|
|
$prefix .= 'bindir';
|
|
}
|
|
push @dirs, $dir;
|
|
$dirnames{$dir} ||= $arg;
|
|
$prefix .= $dir;
|
|
$prefix =~ tr/^a-zA-Z0-9/_/c;
|
|
$prefixes{$dir} = $prefix . '.';
|
|
shift @ARGV;
|
|
}
|
|
|
|
if (not @dirs) {
|
|
@dirs = ('.');
|
|
}
|
|
$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
|
|
$prefixes{'.'} = '';
|
|
|
|
shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
|
|
|
|
@tests = @ARGV;
|
|
if (not @tests) {
|
|
@tests = glob "p????-*.sh";
|
|
}
|
|
|
|
my $resultsdir = "test-results";
|
|
|
|
if (! $subsection and
|
|
exists $ENV{GIT_PERF_SUBSECTION} and
|
|
$ENV{GIT_PERF_SUBSECTION} ne "") {
|
|
$subsection = $ENV{GIT_PERF_SUBSECTION};
|
|
}
|
|
|
|
if ($subsection) {
|
|
$resultsdir .= "/" . $subsection;
|
|
}
|
|
|
|
my @subtests;
|
|
my %shorttests;
|
|
for my $t (@tests) {
|
|
$t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
|
|
my $n = $2;
|
|
my $fname = "$resultsdir/$t.subtests";
|
|
open my $fp, "<", $fname or die "cannot open $fname: $!";
|
|
for (<$fp>) {
|
|
chomp;
|
|
/^(\d+)$/ or die "malformed subtest line: $_";
|
|
push @subtests, "$t.$1";
|
|
$shorttests{"$t.$1"} = "$n.$1";
|
|
}
|
|
close $fp or die "cannot close $fname: $!";
|
|
}
|
|
|
|
sub read_descr {
|
|
my $name = shift;
|
|
open my $fh, "<", $name or return "<error reading description>";
|
|
binmode $fh, ":utf8" or die "PANIC on binmode: $!";
|
|
my $line = <$fh>;
|
|
close $fh or die "cannot close $name";
|
|
chomp $line;
|
|
return $line;
|
|
}
|
|
|
|
sub have_duplicate {
|
|
my %seen;
|
|
for (@_) {
|
|
return 1 if exists $seen{$_};
|
|
$seen{$_} = 1;
|
|
}
|
|
return 0;
|
|
}
|
|
sub have_slash {
|
|
for (@_) {
|
|
return 1 if m{/};
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub display_dir {
|
|
my ($d) = @_;
|
|
return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
|
|
}
|
|
|
|
sub print_default_results {
|
|
my %descrs;
|
|
my $descrlen = 4; # "Test"
|
|
for my $t (@subtests) {
|
|
$descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
|
|
$descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
|
|
}
|
|
|
|
my %newdirabbrevs = %dirabbrevs;
|
|
while (!have_duplicate(values %newdirabbrevs)) {
|
|
%dirabbrevs = %newdirabbrevs;
|
|
last if !have_slash(values %dirabbrevs);
|
|
%newdirabbrevs = %dirabbrevs;
|
|
for (values %newdirabbrevs) {
|
|
s{^[^/]*/}{};
|
|
}
|
|
}
|
|
|
|
my %times;
|
|
my @colwidth = ((0)x@dirs);
|
|
for my $i (0..$#dirs) {
|
|
my $w = length display_dir($dirs[$i]);
|
|
$colwidth[$i] = $w if $w > $colwidth[$i];
|
|
}
|
|
for my $t (@subtests) {
|
|
my $firstr;
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
my $base = "$resultsdir/$prefixes{$d}$t";
|
|
$times{$prefixes{$d}.$t} = [get_times("$base.result")];
|
|
my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
|
|
my $w = length format_times($r,$u,$s,$firstr);
|
|
$colwidth[$i] = $w if $w > $colwidth[$i];
|
|
$firstr = $r unless defined $firstr;
|
|
}
|
|
}
|
|
my $totalwidth = 3*@dirs+$descrlen;
|
|
$totalwidth += $_ for (@colwidth);
|
|
|
|
printf "%-${descrlen}s", "Test";
|
|
for my $i (0..$#dirs) {
|
|
printf " %-$colwidth[$i]s", display_dir($dirs[$i]);
|
|
}
|
|
print "\n";
|
|
print "-"x$totalwidth, "\n";
|
|
for my $t (@subtests) {
|
|
printf "%-${descrlen}s", $descrs{$t};
|
|
my $firstr;
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
|
|
printf " %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
|
|
$firstr = $r unless defined $firstr;
|
|
}
|
|
print "\n";
|
|
}
|
|
}
|
|
|
|
sub print_sorted_results {
|
|
my ($sortby) = @_;
|
|
|
|
if ($sortby ne "regression") {
|
|
print "Only 'regression' is supported as '--sort-by' argument\n";
|
|
usage();
|
|
}
|
|
|
|
my @evolutions;
|
|
for my $t (@subtests) {
|
|
my ($prevr, $prevu, $prevs, $prevrev);
|
|
for my $i (0..$#dirs) {
|
|
my $d = $dirs[$i];
|
|
my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.result");
|
|
if ($i > 0 and defined $r and defined $prevr and $prevr > 0) {
|
|
my $percent = 100.0 * ($r - $prevr) / $prevr;
|
|
push @evolutions, { "percent" => $percent,
|
|
"test" => $t,
|
|
"prevrev" => $prevrev,
|
|
"rev" => $d,
|
|
"prevr" => $prevr,
|
|
"r" => $r,
|
|
"prevu" => $prevu,
|
|
"u" => $u,
|
|
"prevs" => $prevs,
|
|
"s" => $s};
|
|
}
|
|
($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d);
|
|
}
|
|
}
|
|
|
|
my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions;
|
|
|
|
for my $e (@sorted_evolutions) {
|
|
printf "%+.1f%%", $e->{percent};
|
|
print " " . $e->{test};
|
|
print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs});
|
|
print " " . format_times($e->{r}, $e->{u}, $e->{s});
|
|
print " " . display_dir($e->{prevrev});
|
|
print " " . display_dir($e->{rev});
|
|
print "\n";
|
|
}
|
|
}
|
|
|
|
sub print_codespeed_results {
|
|
my ($subsection) = @_;
|
|
|
|
my $project = "Git";
|
|
|
|
my $executable = `uname -s -m`;
|
|
chomp $executable;
|
|
|
|
if ($subsection) {
|
|
$executable .= ", " . $subsection;
|
|
}
|
|
|
|
my $environment;
|
|
if ($reponame) {
|
|
$environment = $reponame;
|
|
} elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
|
|
$environment = $ENV{GIT_PERF_REPO_NAME};
|
|
} else {
|
|
$environment = `uname -r`;
|
|
chomp $environment;
|
|
}
|
|
|
|
my @data;
|
|
|
|
for my $t (@subtests) {
|
|
for my $d (@dirs) {
|
|
my $commitid = $prefixes{$d};
|
|
$commitid =~ s/^build_//;
|
|
$commitid =~ s/\.$//;
|
|
my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.result");
|
|
|
|
my %vals = (
|
|
"commitid" => $commitid,
|
|
"project" => $project,
|
|
"branch" => $dirnames{$d},
|
|
"executable" => $executable,
|
|
"benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
|
|
"environment" => $environment,
|
|
"result_value" => $result_value,
|
|
);
|
|
push @data, \%vals;
|
|
}
|
|
}
|
|
|
|
require JSON;
|
|
print JSON::to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
|
|
}
|
|
|
|
binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
|
|
|
|
if ($codespeed) {
|
|
print_codespeed_results($subsection);
|
|
} elsif (defined $sortby) {
|
|
print_sorted_results($sortby);
|
|
} else {
|
|
print_default_results();
|
|
}
|