t/perf/aggregate.perl

   1 #!/usr/bin/perl
   2
   3 use lib '../../perl/build/lib';
   4 use strict;
   5 use warnings;
   6 use JSON;
   7 use Git;
   8
   9 sub get_times {
  10         my $name = shift;
  11         open my $fh, "<", $name or return undef;
  12         my $line = <$fh>;
  13         return undef if not defined $line;
  14         close $fh or die "cannot close $name: $!";
  15         $line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/
  16                 or die "bad input line: $line";
  17         my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3;
  18         return ($rt, $4, $5);
  19 }
  20
  21 sub format_times {
  22         my ($r, $u, $s, $firstr) = @_;
  23         if (!defined $r) {
  24                 return "<missing>";
  25         }
  26         my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s;
  27         if (defined $firstr) {
  28                 if ($firstr > 0) {
  29                         $out .= sprintf " %+.1f%%", 100.0*($r-$firstr)/$firstr;
  30                 } elsif ($r == 0) {
  31                         $out .= " =";
  32                 } else {
  33                         $out .= " +inf";
  34                 }
  35         }
  36         return $out;
  37 }
  38
  39 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
  40     $codespeed, $sortby, $subsection, $reponame);
  41 while (scalar @ARGV) {
  42         my $arg = $ARGV[0];
  43         my $dir;
  44         if ($arg eq "--codespeed") {
  45                 $codespeed = 1;
  46                 shift @ARGV;
  47                 next;
  48         }
  49         if ($arg =~ /--sort-by(?:=(.*))?/) {
  50                 shift @ARGV;
  51                 if (defined $1) {
  52                         $sortby = $1;
  53                 } else {
  54                         $sortby = shift @ARGV;
  55                         if (! defined $sortby) {
  56                                 die "'--sort-by' requires an argument";
  57                         }
  58                 }
  59                 next;
  60         }
  61         if ($arg eq "--subsection") {
  62                 shift @ARGV;
  63                 $subsection = $ARGV[0];
  64                 shift @ARGV;
  65                 if (! $subsection) {
  66                         die "empty subsection";
  67                 }
  68                 next;
  69         }
  70         if ($arg eq "--reponame") {
  71                 shift @ARGV;
  72                 $reponame = $ARGV[0];
  73                 shift @ARGV;
  74                 if (! $reponame) {
  75                         die "empty reponame";
  76                 }
  77                 next;
  78         }
  79         last if -f $arg or $arg eq "--";
  80         if (! -d $arg) {
  81                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
  82                 $dir = "build/".$rev;
  83         } else {
  84                 $arg =~ s{/*$}{};
  85                 $dir = $arg;
  86                 $dirabbrevs{$dir} = $dir;
  87         }
  88         push @dirs, $dir;
  89         $dirnames{$dir} = $arg;
  90         my $prefix = $dir;
  91         $prefix =~ tr/^a-zA-Z0-9/_/c;
  92         $prefixes{$dir} = $prefix . '.';
  93         shift @ARGV;
  94 }
  95
  96 if (not @dirs) {
  97         @dirs = ('.');
  98 }
  99 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
 100 $prefixes{'.'} = '';
 101
 102 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
 103
 104 @tests = @ARGV;
 105 if (not @tests) {
 106         @tests = glob "p????-*.sh";
 107 }
 108
 109 my $resultsdir = "test-results";
 110
 111 if (! $subsection and
 112     exists $ENV{GIT_PERF_SUBSECTION} and
 113     $ENV{GIT_PERF_SUBSECTION} ne "") {
 114         $subsection = $ENV{GIT_PERF_SUBSECTION};
 115 }
 116
 117 if ($subsection) {
 118         $resultsdir .= "/" . $subsection;
 119 }
 120
 121 my @subtests;
 122 my %shorttests;
 123 for my $t (@tests) {
 124         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
 125         my $n = $2;
 126         my $fname = "$resultsdir/$t.subtests";
 127         open my $fp, "<", $fname or die "cannot open $fname: $!";
 128         for (<$fp>) {
 129                 chomp;
 130                 /^(\d+)$/ or die "malformed subtest line: $_";
 131                 push @subtests, "$t.$1";
 132                 $shorttests{"$t.$1"} = "$n.$1";
 133         }
 134         close $fp or die "cannot close $fname: $!";
 135 }
 136
 137 sub read_descr {
 138         my $name = shift;
 139         open my $fh, "<", $name or return "<error reading description>";
 140         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
 141         my $line = <$fh>;
 142         close $fh or die "cannot close $name";
 143         chomp $line;
 144         return $line;
 145 }
 146
 147 sub have_duplicate {
 148         my %seen;
 149         for (@_) {
 150                 return 1 if exists $seen{$_};
 151                 $seen{$_} = 1;
 152         }
 153         return 0;
 154 }
 155 sub have_slash {
 156         for (@_) {
 157                 return 1 if m{/};
 158         }
 159         return 0;
 160 }
 161
 162 sub display_dir {
 163         my ($d) = @_;
 164         return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
 165 }
 166
 167 sub print_default_results {
 168         my %descrs;
 169         my $descrlen = 4; # "Test"
 170         for my $t (@subtests) {
 171                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
 172                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
 173         }
 174
 175         my %newdirabbrevs = %dirabbrevs;
 176         while (!have_duplicate(values %newdirabbrevs)) {
 177                 %dirabbrevs = %newdirabbrevs;
 178                 last if !have_slash(values %dirabbrevs);
 179                 %newdirabbrevs = %dirabbrevs;
 180                 for (values %newdirabbrevs) {
 181                         s{^[^/]*/}{};
 182                 }
 183         }
 184
 185         my %times;
 186         my @colwidth = ((0)x@dirs);
 187         for my $i (0..$#dirs) {
 188                 my $w = length display_dir($dirs[$i]);
 189                 $colwidth[$i] = $w if $w > $colwidth[$i];
 190         }
 191         for my $t (@subtests) {
 192                 my $firstr;
 193                 for my $i (0..$#dirs) {
 194                         my $d = $dirs[$i];
 195                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
 196                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 197                         my $w = length format_times($r,$u,$s,$firstr);
 198                         $colwidth[$i] = $w if $w > $colwidth[$i];
 199                         $firstr = $r unless defined $firstr;
 200                 }
 201         }
 202         my $totalwidth = 3*@dirs+$descrlen;
 203         $totalwidth += $_ for (@colwidth);
 204
 205         printf "%-${descrlen}s", "Test";
 206         for my $i (0..$#dirs) {
 207                 printf "   %-$colwidth[$i]s", display_dir($dirs[$i]);
 208         }
 209         print "\n";
 210         print "-"x$totalwidth, "\n";
 211         for my $t (@subtests) {
 212                 printf "%-${descrlen}s", $descrs{$t};
 213                 my $firstr;
 214                 for my $i (0..$#dirs) {
 215                         my $d = $dirs[$i];
 216                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 217                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
 218                         $firstr = $r unless defined $firstr;
 219                 }
 220                 print "\n";
 221         }
 222 }
 223
 224 sub print_sorted_results {
 225         my ($sortby) = @_;
 226
 227         if ($sortby ne "regression") {
 228                 die "only 'regression' is supported as '--sort-by' argument";
 229         }
 230
 231         my @evolutions;
 232         for my $t (@subtests) {
 233                 my ($prevr, $prevu, $prevs, $prevrev);
 234                 for my $i (0..$#dirs) {
 235                         my $d = $dirs[$i];
 236                         my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
 237                         if ($i > 0 and defined $r and defined $prevr and $prevr > 0) {
 238                                 my $percent = 100.0 * ($r - $prevr) / $prevr;
 239                                 push @evolutions, { "percent"  => $percent,
 240                                                     "test"     => $t,
 241                                                     "prevrev"  => $prevrev,
 242                                                     "rev"      => $d,
 243                                                     "prevr"    => $prevr,
 244                                                     "r"        => $r,
 245                                                     "prevu"    => $prevu,
 246                                                     "u"        => $u,
 247                                                     "prevs"    => $prevs,
 248                                                     "s"        => $s};
 249                         }
 250                         ($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d);
 251                 }
 252         }
 253
 254         my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions;
 255
 256         for my $e (@sorted_evolutions) {
 257                 printf "%+.1f%%", $e->{percent};
 258                 print " " . $e->{test};
 259                 print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs});
 260                 print " " . format_times($e->{r}, $e->{u}, $e->{s});
 261                 print " " . display_dir($e->{prevrev});
 262                 print " " . display_dir($e->{rev});
 263                 print "\n";
 264         }
 265 }
 266
 267 sub print_codespeed_results {
 268         my ($subsection) = @_;
 269
 270         my $project = "Git";
 271
 272         my $executable = `uname -s -m`;
 273         chomp $executable;
 274
 275         if ($subsection) {
 276                 $executable .= ", " . $subsection;
 277         }
 278
 279         my $environment;
 280         if ($reponame) {
 281                 $environment = $reponame;
 282         } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
 283                 $environment = $ENV{GIT_PERF_REPO_NAME};
 284         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
 285                 $environment = $ENV{GIT_TEST_INSTALLED};
 286                 $environment =~ s|/bin-wrappers$||;
 287         } else {
 288                 $environment = `uname -r`;
 289                 chomp $environment;
 290         }
 291
 292         my @data;
 293
 294         for my $t (@subtests) {
 295                 for my $d (@dirs) {
 296                         my $commitid = $prefixes{$d};
 297                         $commitid =~ s/^build_//;
 298                         $commitid =~ s/\.$//;
 299                         my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
 300
 301                         my %vals = (
 302                                 "commitid" => $commitid,
 303                                 "project" => $project,
 304                                 "branch" => $dirnames{$d},
 305                                 "executable" => $executable,
 306                                 "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
 307                                 "environment" => $environment,
 308                                 "result_value" => $result_value,
 309                             );
 310                         push @data, \%vals;
 311                 }
 312         }
 313
 314         print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
 315 }
 316
 317 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
 318
 319 if ($codespeed) {
 320         print_codespeed_results($subsection);
 321 } elsif (defined $sortby) {
 322         print_sorted_results($sortby);
 323 } else {
 324         print_default_results();
 325 }