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