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

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