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