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