Andrew's git / gitweb.git / t/perf/aggregate.perl
?
t / perf / aggregate.perlon commit Merge branch 'md/exclude-promisor-objects-fix' into maint (b52ac60)
   1#!/usr/bin/perl
   2
   3use lib '../../perl/build/lib';
   4use strict;
   5use warnings;
   6use JSON;
   7use Getopt::Long;
   8use Git;
   9
  10sub 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
  22sub 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
  40sub 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
  50EOT
  51        exit(1);
  52}
  53
  54my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
  55    $codespeed, $sortby, $subsection, $reponame);
  56
  57Getopt::Long::Configure qw/ require_order /;
  58
  59my $rc = GetOptions("codespeed"     => \$codespeed,
  60                    "reponame=s"    => \$reponame,
  61                    "sort-by=s"     => \$sortby,
  62                    "subsection=s"  => \$subsection);
  63usage() unless $rc;
  64
  65while (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
  85if (not @dirs) {
  86        @dirs = ('.');
  87}
  88$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
  89$prefixes{'.'} = '';
  90
  91shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
  92
  93@tests = @ARGV;
  94if (not @tests) {
  95        @tests = glob "p????-*.sh";
  96}
  97
  98my $resultsdir = "test-results";
  99
 100if (! $subsection and
 101    exists $ENV{GIT_PERF_SUBSECTION} and
 102    $ENV{GIT_PERF_SUBSECTION} ne "") {
 103        $subsection = $ENV{GIT_PERF_SUBSECTION};
 104}
 105
 106if ($subsection) {
 107        $resultsdir .= "/" . $subsection;
 108}
 109
 110my @subtests;
 111my %shorttests;
 112for 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
 126sub 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
 136sub have_duplicate {
 137        my %seen;
 138        for (@_) {
 139                return 1 if exists $seen{$_};
 140                $seen{$_} = 1;
 141        }
 142        return 0;
 143}
 144sub have_slash {
 145        for (@_) {
 146                return 1 if m{/};
 147        }
 148        return 0;
 149}
 150
 151sub display_dir {
 152        my ($d) = @_;
 153        return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
 154}
 155
 156sub 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
 213sub 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
 257sub 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
 307binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
 308
 309if ($codespeed) {
 310        print_codespeed_results($subsection);
 311} elsif (defined $sortby) {
 312        print_sorted_results($sortby);
 313} else {
 314        print_default_results();
 315}