diff options
Diffstat (limited to 't/perf/aggregate.perl')
| -rwxr-xr-x | t/perf/aggregate.perl | 265 |
1 files changed, 265 insertions, 0 deletions
diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl new file mode 100755 index 0000000000..821cf1498b --- /dev/null +++ b/t/perf/aggregate.perl @@ -0,0 +1,265 @@ +#!/usr/bin/perl + +use lib '../../perl/build/lib'; +use strict; +use warnings; +use JSON; +use Git; + +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: $!"; + $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/ + or die "bad input line: $line"; + my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3; + return ($rt, $4, $5); +} + +sub format_times { + my ($r, $u, $s, $firstr) = @_; + if (!defined $r) { + return "<missing>"; + } + my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s; + if (defined $firstr) { + if ($firstr > 0) { + $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr; + } elsif ($r == 0) { + $out .= " ="; + } else { + $out .= " +inf"; + } + } + return $out; +} + +my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests, + $codespeed, $subsection, $reponame); +while (scalar @ARGV) { + my $arg = $ARGV[0]; + my $dir; + if ($arg eq "--codespeed") { + $codespeed = 1; + shift @ARGV; + next; + } + if ($arg eq "--subsection") { + shift @ARGV; + $subsection = $ARGV[0]; + shift @ARGV; + if (! $subsection) { + die "empty subsection"; + } + next; + } + if ($arg eq "--reponame") { + shift @ARGV; + $reponame = $ARGV[0]; + shift @ARGV; + if (! $reponame) { + die "empty reponame"; + } + next; + } + last if -f $arg or $arg eq "--"; + if (! -d $arg) { + my $rev = Git::command_oneline(qw(rev-parse --verify), $arg); + $dir = "build/".$rev; + } else { + $arg =~ s{/*$}{}; + $dir = $arg; + $dirabbrevs{$dir} = $dir; + } + push @dirs, $dir; + $dirnames{$dir} = $arg; + my $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 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]; + my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}); + $colwidth[$i] = $w if $w > $colwidth[$i]; + } + 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; + 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_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); +} else { + print_default_results(); +} |