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

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Git;
   6
   7 sub 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
  19 sub 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
  37 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests);
  38 while (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
  58 if (not @dirs) {
  59         @dirs = ('.');
  60 }
  61 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
  62 $prefixes{'.'} = '';
  63
  64 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
  65
  66 @tests = @ARGV;
  67 if (not @tests) {
  68         @tests = glob "p????-*.sh";
  69 }
  70
  71 my @subtests;
  72 my %shorttests;
  73 for 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
  87 sub 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
  96 my %descrs;
  97 my $descrlen = 4; # "Test"
  98 for 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
 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 my %newdirabbrevs = %dirabbrevs;
 119 while (!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
 128 my %times;
 129 my @colwidth = ((0)x@dirs);
 130 for 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 }
 135 for 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 }
 146 my $totalwidth = 3*@dirs+$descrlen;
 147 $totalwidth += $_ for (@colwidth);
 148
 149 printf "%-${descrlen}s", "Test";
 150 for my $i (0..$#dirs) {
 151         my $d = $dirs[$i];
 152         printf "   %-$colwidth[$i]s", (exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d});
 153 }
 154 print "\n";
 155 print "-"x$totalwidth, "\n";
 156 for 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 }