diff options
Diffstat (limited to 't/perf/aggregate.perl')
| -rwxr-xr-x | t/perf/aggregate.perl | 246 |
1 files changed, 197 insertions, 49 deletions
diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl index 924b19dab4..bc865160e7 100755 --- a/t/perf/aggregate.perl +++ b/t/perf/aggregate.perl @@ -1,8 +1,10 @@ #!/usr/bin/perl -use lib '../../perl/blib/lib'; +use lib '../../perl/build/lib'; use strict; use warnings; +use JSON; +use Getopt::Long; use Git; sub get_times { @@ -35,7 +37,31 @@ sub format_times { return $out; } -my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests); +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); +} + +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; @@ -69,12 +95,24 @@ 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 = "test-results/$t.subtests"; + my $fname = "$resultsdir/$t.subtests"; open my $fp, "<", $fname or die "cannot open $fname: $!"; for (<$fp>) { chomp; @@ -88,19 +126,13 @@ for my $t (@tests) { 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; } -my %descrs; -my $descrlen = 4; # "Test" -for my $t (@subtests) { - $descrs{$t} = $shorttests{$t}.": ".read_descr("test-results/$t.descr"); - $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen; -} - sub have_duplicate { my %seen; for (@_) { @@ -116,52 +148,168 @@ sub have_slash { return 0; } -my %newdirabbrevs = %dirabbrevs; -while (!have_duplicate(values %newdirabbrevs)) { - %dirabbrevs = %newdirabbrevs; - last if !have_slash(values %dirabbrevs); - %newdirabbrevs = %dirabbrevs; - for (values %newdirabbrevs) { - s{^[^/]*/}{}; - } +sub display_dir { + my ($d) = @_; + return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}; } -my %times; -my @colwidth = ((0)x@dirs); -for my $i (0..$#dirs) { - my $d = $dirs[$i]; - my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}); - $colwidth[$i] = $w if $w > $colwidth[$i]; -} -for my $t (@subtests) { - my $firstr; +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 $d = $dirs[$i]; - $times{$prefixes{$d}.$t} = [get_times("test-results/$prefixes{$d}$t.times")]; - my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}}; - my $w = length format_times($r,$u,$s,$firstr); + my $w = length display_dir($dirs[$i]); $colwidth[$i] = $w if $w > $colwidth[$i]; - $firstr = $r unless defined $firstr; } -} -my $totalwidth = 3*@dirs+$descrlen; -$totalwidth += $_ for (@colwidth); + for my $t (@subtests) { + my $firstr; + for my $i (0..$#dirs) { + my $d = $dirs[$i]; + $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")]; + 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) { - my $d = $dirs[$i]; - printf " %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}); -} -print "\n"; -print "-"x$totalwidth, "\n"; -for my $t (@subtests) { - printf "%-${descrlen}s", $descrs{$t}; - my $firstr; + printf "%-${descrlen}s", "Test"; 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; + 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.times"); + 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}; + } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") { + $environment = $ENV{GIT_TEST_INSTALLED}; + $environment =~ s|/bin-wrappers$||; + } 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.times"); + + 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; + } + } + + print 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(); } |