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