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