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