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