diff options
Diffstat (limited to 't/perf/aggregate.perl')
| -rwxr-xr-x | t/perf/aggregate.perl | 170 |
1 files changed, 170 insertions, 0 deletions
diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl new file mode 100755 index 0000000000..1dbc85b214 --- /dev/null +++ b/t/perf/aggregate.perl @@ -0,0 +1,170 @@ +#!/usr/bin/perl + +use lib '../../perl/blib/lib'; +use strict; +use warnings; +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); +while (scalar @ARGV) { + my $arg = $ARGV[0]; + my $dir; + 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 @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"; + 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; +} + +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 (@_) { + return 1 if exists $seen{$_}; + $seen{$_} = 1; + } + return 0; +} +sub have_slash { + for (@_) { + return 1 if m{/}; + } + return 0; +} + +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("test-results/$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); + +binmode STDOUT, ":utf8" or die "PANIC on binmode: $!"; + +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"; +} |