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