git.oblomov.eu Git - git/blob - t/perf/aggregate.perl

   1 #!/usr/bin/perl
   2
   3 use lib '../../perl/blib/lib';
   4 use strict;
   5 use warnings;
   6 use Git;
   7
   8 sub 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
  20 sub 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
  38 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
  39 while (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
  59 if (not @dirs) {
  60         @dirs = ('.');
  61 }
  62 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
  63 $prefixes{'.'} = '';
  64
  65 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
  66
  67 @tests = @ARGV;
  68 if (not @tests) {
  69         @tests = glob "p????-*.sh";
  70 }
  71
  72 my $resultsdir = "test-results";
  73 if (exists $ENV{GIT_PERF_SUBSECTION} and $ENV{GIT_PERF_SUBSECTION} ne "") {
  74         $resultsdir .= "/" . $ENV{GIT_PERF_SUBSECTION};
  75 }
  76
  77 my @subtests;
  78 my %shorttests;
  79 for 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
  93 sub 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
 103 sub have_duplicate {
 104         my %seen;
 105         for (@_) {
 106                 return 1 if exists $seen{$_};
 107                 $seen{$_} = 1;
 108         }
 109         return 0;
 110 }
 111 sub have_slash {
 112         for (@_) {
 113                 return 1 if m{/};
 114         }
 115         return 0;
 116 }
 117
 118 sub print_default_results {
 119         my %descrs;
 120         my $descrlen = 4; # "Test"
 121         for my $t (@subtests) {
 122                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
 123                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
 124         }
 125
 126         my %newdirabbrevs = %dirabbrevs;
 127         while (!have_duplicate(values %newdirabbrevs)) {
 128                 %dirabbrevs = %newdirabbrevs;
 129                 last if !have_slash(values %dirabbrevs);
 130                 %newdirabbrevs = %dirabbrevs;
 131                 for (values %newdirabbrevs) {
 132                         s{^[^/]*/}{};
 133                 }
 134         }
 135
 136         my %times;
 137         my @colwidth = ((0)x@dirs);
 138         for my $i (0..$#dirs) {
 139                 my $d = $dirs[$i];
 140                 my $w = length (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
 141                 $colwidth[$i] = $w if $w > $colwidth[$i];
 142         }
 143         for my $t (@subtests) {
 144                 my $firstr;
 145                 for my $i (0..$#dirs) {
 146                         my $d = $dirs[$i];
 147                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
 148                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 149                         my $w = length format_times($r,$u,$s,$firstr);
 150                         $colwidth[$i] = $w if $w > $colwidth[$i];
 151                         $firstr = $r unless defined $firstr;
 152                 }
 153         }
 154         my $totalwidth = 3*@dirs+$descrlen;
 155         $totalwidth += $_ for (@colwidth);
 156
 157         printf "%-${descrlen}s", "Test";
 158         for my $i (0..$#dirs) {
 159                 my $d = $dirs[$i];
 160                 printf "   %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
 161         }
 162         print "\n";
 163         print "-"x$totalwidth, "\n";
 164         for my $t (@subtests) {
 165                 printf "%-${descrlen}s", $descrs{$t};
 166                 my $firstr;
 167                 for my $i (0..$#dirs) {
 168                         my $d = $dirs[$i];
 169                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 170                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
 171                         $firstr = $r unless defined $firstr;
 172                 }
 173                 print "\n";
 174         }
 175 }
 176
 177 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
 178
 179 print_default_results();