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, $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 eq "--subsection") {
  50                 shift @ARGV;
  51                 $subsection = $ARGV[0];
  52                 shift @ARGV;
  53                 if (! $subsection) {
  54                         die "empty subsection";
  55                 }
  56                 next;
  57         }
  58         if ($arg eq "--reponame") {
  59                 shift @ARGV;
  60                 $reponame = $ARGV[0];
  61                 shift @ARGV;
  62                 if (! $reponame) {
  63                         die "empty reponame";
  64                 }
  65                 next;
  66         }
  67         last if -f $arg or $arg eq "--";
  68         if (! -d $arg) {
  69                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
  70                 $dir = "build/".$rev;
  71         } else {
  72                 $arg =~ s{/*$}{};
  73                 $dir = $arg;
  74                 $dirabbrevs{$dir} = $dir;
  75         }
  76         push @dirs, $dir;
  77         $dirnames{$dir} = $arg;
  78         my $prefix = $dir;
  79         $prefix =~ tr/^a-zA-Z0-9/_/c;
  80         $prefixes{$dir} = $prefix . '.';
  81         shift @ARGV;
  82 }
  83
  84 if (not @dirs) {
  85         @dirs = ('.');
  86 }
  87 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
  88 $prefixes{'.'} = '';
  89
  90 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
  91
  92 @tests = @ARGV;
  93 if (not @tests) {
  94         @tests = glob "p????-*.sh";
  95 }
  96
  97 my $resultsdir = "test-results";
  98
  99 if (! $subsection and
 100     exists $ENV{GIT_PERF_SUBSECTION} and
 101     $ENV{GIT_PERF_SUBSECTION} ne "") {
 102         $subsection = $ENV{GIT_PERF_SUBSECTION};
 103 }
 104
 105 if ($subsection) {
 106         $resultsdir .= "/" . $subsection;
 107 }
 108
 109 my @subtests;
 110 my %shorttests;
 111 for my $t (@tests) {
 112         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
 113         my $n = $2;
 114         my $fname = "$resultsdir/$t.subtests";
 115         open my $fp, "<", $fname or die "cannot open $fname: $!";
 116         for (<$fp>) {
 117                 chomp;
 118                 /^(\d+)$/ or die "malformed subtest line: $_";
 119                 push @subtests, "$t.$1";
 120                 $shorttests{"$t.$1"} = "$n.$1";
 121         }
 122         close $fp or die "cannot close $fname: $!";
 123 }
 124
 125 sub read_descr {
 126         my $name = shift;
 127         open my $fh, "<", $name or return "<error reading description>";
 128         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
 129         my $line = <$fh>;
 130         close $fh or die "cannot close $name";
 131         chomp $line;
 132         return $line;
 133 }
 134
 135 sub have_duplicate {
 136         my %seen;
 137         for (@_) {
 138                 return 1 if exists $seen{$_};
 139                 $seen{$_} = 1;
 140         }
 141         return 0;
 142 }
 143 sub have_slash {
 144         for (@_) {
 145                 return 1 if m{/};
 146         }
 147         return 0;
 148 }
 149
 150 sub display_dir {
 151         my ($d) = @_;
 152         return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
 153 }
 154
 155 sub print_default_results {
 156         my %descrs;
 157         my $descrlen = 4; # "Test"
 158         for my $t (@subtests) {
 159                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
 160                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
 161         }
 162
 163         my %newdirabbrevs = %dirabbrevs;
 164         while (!have_duplicate(values %newdirabbrevs)) {
 165                 %dirabbrevs = %newdirabbrevs;
 166                 last if !have_slash(values %dirabbrevs);
 167                 %newdirabbrevs = %dirabbrevs;
 168                 for (values %newdirabbrevs) {
 169                         s{^[^/]*/}{};
 170                 }
 171         }
 172
 173         my %times;
 174         my @colwidth = ((0)x@dirs);
 175         for my $i (0..$#dirs) {
 176                 my $w = length display_dir($dirs[$i]);
 177                 $colwidth[$i] = $w if $w > $colwidth[$i];
 178         }
 179         for my $t (@subtests) {
 180                 my $firstr;
 181                 for my $i (0..$#dirs) {
 182                         my $d = $dirs[$i];
 183                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
 184                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 185                         my $w = length format_times($r,$u,$s,$firstr);
 186                         $colwidth[$i] = $w if $w > $colwidth[$i];
 187                         $firstr = $r unless defined $firstr;
 188                 }
 189         }
 190         my $totalwidth = 3*@dirs+$descrlen;
 191         $totalwidth += $_ for (@colwidth);
 192
 193         printf "%-${descrlen}s", "Test";
 194         for my $i (0..$#dirs) {
 195                 printf "   %-$colwidth[$i]s", display_dir($dirs[$i]);
 196         }
 197         print "\n";
 198         print "-"x$totalwidth, "\n";
 199         for my $t (@subtests) {
 200                 printf "%-${descrlen}s", $descrs{$t};
 201                 my $firstr;
 202                 for my $i (0..$#dirs) {
 203                         my $d = $dirs[$i];
 204                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
 205                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
 206                         $firstr = $r unless defined $firstr;
 207                 }
 208                 print "\n";
 209         }
 210 }
 211
 212 sub print_codespeed_results {
 213         my ($subsection) = @_;
 214
 215         my $project = "Git";
 216
 217         my $executable = `uname -s -m`;
 218         chomp $executable;
 219
 220         if ($subsection) {
 221                 $executable .= ", " . $subsection;
 222         }
 223
 224         my $environment;
 225         if ($reponame) {
 226                 $environment = $reponame;
 227         } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
 228                 $environment = $ENV{GIT_PERF_REPO_NAME};
 229         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
 230                 $environment = $ENV{GIT_TEST_INSTALLED};
 231                 $environment =~ s|/bin-wrappers$||;
 232         } else {
 233                 $environment = `uname -r`;
 234                 chomp $environment;
 235         }
 236
 237         my @data;
 238
 239         for my $t (@subtests) {
 240                 for my $d (@dirs) {
 241                         my $commitid = $prefixes{$d};
 242                         $commitid =~ s/^build_//;
 243                         $commitid =~ s/\.$//;
 244                         my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
 245
 246                         my %vals = (
 247                                 "commitid" => $commitid,
 248                                 "project" => $project,
 249                                 "branch" => $dirnames{$d},
 250                                 "executable" => $executable,
 251                                 "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
 252                                 "environment" => $environment,
 253                                 "result_value" => $result_value,
 254                             );
 255                         push @data, \%vals;
 256                 }
 257         }
 258
 259         print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
 260 }
 261
 262 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
 263
 264 if ($codespeed) {
 265         print_codespeed_results($subsection);
 266 } else {
 267         print_default_results();
 268 }