diff options
Diffstat (limited to 't/perf/aggregate.perl')
| -rwxr-xr-x | t/perf/aggregate.perl | 357 |
1 files changed, 357 insertions, 0 deletions
diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl new file mode 100755 index 0000000..575d200 --- /dev/null +++ b/t/perf/aggregate.perl @@ -0,0 +1,357 @@ +#!/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 =~ /^\s*(\d+)$/) { + return $1; + } 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 + --results-dir <str> * Directory where test results are located + --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); +my $resultsdir = "test-results"; + +Getopt::Long::Configure qw/ require_order /; + +my $rc = GetOptions("codespeed" => \$codespeed, + "reponame=s" => \$reponame, + "results-dir=s" => \$resultsdir, + "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"; +} + +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(); +} |