t / perf / aggregate.perlon commit Merge branch 'pc/submodule-helper' (41a05ee)
   1#!/usr/bin/perl
   2
   3use lib '../../perl/blib/lib';
   4use strict;
   5use warnings;
   6use Git;
   7
   8sub get_times {
   9        my $name = shift;
  10        open my $fh, "<", $name or return undef;
  11        my $line = <$fh>;
  12        return undef if not defined $line;
  13        close $fh or die "cannot close $name: $!";
  14        $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
  15                or die "bad input line: $line";
  16        my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
  17        return ($rt, $4, $5);
  18}
  19
  20sub format_times {
  21        my ($r, $u, $s, $firstr) = @_;
  22        if (!defined $r) {
  23                return "<missing>";
  24        }
  25        my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
  26        if (defined $firstr) {
  27                if ($firstr > 0) {
  28                        $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
  29                } elsif ($r == 0) {
  30                        $out .= " =";
  31                } else {
  32                        $out .= " +inf";
  33                }
  34        }
  35        return $out;
  36}
  37
  38my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
  39while (scalar @ARGV) {
  40        my $arg = $ARGV[0];
  41        my $dir;
  42        last if -f $arg or $arg eq "--";
  43        if (! -d $arg) {
  44                my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
  45                $dir = "build/".$rev;
  46        } else {
  47                $arg =~ s{/*$}{};
  48                $dir = $arg;
  49                $dirabbrevs{$dir} = $dir;
  50        }
  51        push @dirs, $dir;
  52        $dirnames{$dir} = $arg;
  53        my $prefix = $dir;
  54        $prefix =~ tr/^a-zA-Z0-9/_/c;
  55        $prefixes{$dir} = $prefix . '.';
  56        shift @ARGV;
  57}
  58
  59if (not @dirs) {
  60        @dirs = ('.');
  61}
  62$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
  63$prefixes{'.'} = '';
  64
  65shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
  66
  67@tests = @ARGV;
  68if (not @tests) {
  69        @tests = glob "p????-*.sh";
  70}
  71
  72my $resultsdir = "test-results";
  73if ($ENV{GIT_PERF_SUBSECTION} ne "") {
  74        $resultsdir .= "/" . $ENV{GIT_PERF_SUBSECTION};
  75}
  76
  77my @subtests;
  78my %shorttests;
  79for my $t (@tests) {
  80        $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
  81        my $n = $2;
  82        my $fname = "$resultsdir/$t.subtests";
  83        open my $fp, "<", $fname or die "cannot open $fname: $!";
  84        for (<$fp>) {
  85                chomp;
  86                /^(\d+)$/ or die "malformed subtest line: $_";
  87                push @subtests, "$t.$1";
  88                $shorttests{"$t.$1"} = "$n.$1";
  89        }
  90        close $fp or die "cannot close $fname: $!";
  91}
  92
  93sub read_descr {
  94        my $name = shift;
  95        open my $fh, "<", $name or return "<error reading description>";
  96        binmode $fh, ":utf8" or die "PANIC on binmode: $!";
  97        my $line = <$fh>;
  98        close $fh or die "cannot close $name";
  99        chomp $line;
 100        return $line;
 101}
 102
 103my %descrs;
 104my $descrlen = 4; # "Test"
 105for my $t (@subtests) {
 106        $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
 107        $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
 108}
 109
 110sub have_duplicate {
 111        my %seen;
 112        for (@_) {
 113                return 1 if exists $seen{$_};
 114                $seen{$_} = 1;
 115        }
 116        return 0;
 117}
 118sub have_slash {
 119        for (@_) {
 120                return 1 if m{/};
 121        }
 122        return 0;
 123}
 124
 125my %newdirabbrevs = %dirabbrevs;
 126while (!have_duplicate(values %newdirabbrevs)) {
 127        %dirabbrevs = %newdirabbrevs;
 128        last if !have_slash(values %dirabbrevs);
 129        %newdirabbrevs = %dirabbrevs;
 130        for (values %newdirabbrevs) {
 131                s{^[^/]*/}{};
 132        }
 133}
 134
 135my %times;
 136my @colwidth = ((0)x@dirs);
 137for my $i (0..$#dirs) {
 138        my $d = $dirs[$i];
 139        my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
 140        $colwidth[$i] = $w if $w > $colwidth[$i];
 141}
 142for my $t (@subtests) {
 143        my $firstr;
 144        for my $i (0..$#dirs) {
 145                my $d = $dirs[$i];
 146                $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
 147                my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 148                my $w = length format_times($r,$u,$s,$firstr);
 149                $colwidth[$i] = $w if $w > $colwidth[$i];
 150                $firstr = $r unless defined $firstr;
 151        }
 152}
 153my $totalwidth = 3*@dirs+$descrlen;
 154$totalwidth += $_ for (@colwidth);
 155
 156binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
 157
 158printf "%-${descrlen}s", "Test";
 159for my $i (0..$#dirs) {
 160        my $d = $dirs[$i];
 161        printf "   %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
 162}
 163print "\n";
 164print "-"x$totalwidth, "\n";
 165for my $t (@subtests) {
 166        printf "%-${descrlen}s", $descrs{$t};
 167        my $firstr;
 168        for my $i (0..$#dirs) {
 169                my $d = $dirs[$i];
 170                my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 171                printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
 172                $firstr = $r unless defined $firstr;
 173        }
 174        print "\n";
 175}