Merge branch 'jk/stream-pack-non-delta-clarification'
[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         # 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         last if -f $arg or $arg eq "--";
103         if (! -d $arg) {
104                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
105                 $dir = "build/".$rev;
106         } else {
107                 $arg =~ s{/*$}{};
108                 $dir = $arg;
109                 $dirabbrevs{$dir} = $dir;
110         }
111         push @dirs, $dir;
112         $dirnames{$dir} = $arg;
113         my $prefix = $dir;
114         $prefix =~ tr/^a-zA-Z0-9/_/c;
115         $prefixes{$dir} = $prefix . '.';
116         shift @ARGV;
117 }
118
119 if (not @dirs) {
120         @dirs = ('.');
121 }
122 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
123 $prefixes{'.'} = '';
124
125 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
126
127 @tests = @ARGV;
128 if (not @tests) {
129         @tests = glob "p????-*.sh";
130 }
131
132 my $resultsdir = "test-results";
133
134 if (! $subsection and
135     exists $ENV{GIT_PERF_SUBSECTION} and
136     $ENV{GIT_PERF_SUBSECTION} ne "") {
137         $subsection = $ENV{GIT_PERF_SUBSECTION};
138 }
139
140 if ($subsection) {
141         $resultsdir .= "/" . $subsection;
142 }
143
144 my @subtests;
145 my %shorttests;
146 for my $t (@tests) {
147         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
148         my $n = $2;
149         my $fname = "$resultsdir/$t.subtests";
150         open my $fp, "<", $fname or die "cannot open $fname: $!";
151         for (<$fp>) {
152                 chomp;
153                 /^(\d+)$/ or die "malformed subtest line: $_";
154                 push @subtests, "$t.$1";
155                 $shorttests{"$t.$1"} = "$n.$1";
156         }
157         close $fp or die "cannot close $fname: $!";
158 }
159
160 sub read_descr {
161         my $name = shift;
162         open my $fh, "<", $name or return "<error reading description>";
163         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
164         my $line = <$fh>;
165         close $fh or die "cannot close $name";
166         chomp $line;
167         return $line;
168 }
169
170 sub have_duplicate {
171         my %seen;
172         for (@_) {
173                 return 1 if exists $seen{$_};
174                 $seen{$_} = 1;
175         }
176         return 0;
177 }
178 sub have_slash {
179         for (@_) {
180                 return 1 if m{/};
181         }
182         return 0;
183 }
184
185 sub display_dir {
186         my ($d) = @_;
187         return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
188 }
189
190 sub print_default_results {
191         my %descrs;
192         my $descrlen = 4; # "Test"
193         for my $t (@subtests) {
194                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
195                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
196         }
197
198         my %newdirabbrevs = %dirabbrevs;
199         while (!have_duplicate(values %newdirabbrevs)) {
200                 %dirabbrevs = %newdirabbrevs;
201                 last if !have_slash(values %dirabbrevs);
202                 %newdirabbrevs = %dirabbrevs;
203                 for (values %newdirabbrevs) {
204                         s{^[^/]*/}{};
205                 }
206         }
207
208         my %times;
209         my @colwidth = ((0)x@dirs);
210         for my $i (0..$#dirs) {
211                 my $w = length display_dir($dirs[$i]);
212                 $colwidth[$i] = $w if $w > $colwidth[$i];
213         }
214         for my $t (@subtests) {
215                 my $firstr;
216                 for my $i (0..$#dirs) {
217                         my $d = $dirs[$i];
218                         my $base = "$resultsdir/$prefixes{$d}$t";
219                         $times{$prefixes{$d}.$t} = [];
220                         foreach my $type (qw(times size)) {
221                                 if (-e "$base.$type") {
222                                         $times{$prefixes{$d}.$t} = [get_times("$base.$type")];
223                                         last;
224                                 }
225                         }
226                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
227                         my $w = length format_times($r,$u,$s,$firstr);
228                         $colwidth[$i] = $w if $w > $colwidth[$i];
229                         $firstr = $r unless defined $firstr;
230                 }
231         }
232         my $totalwidth = 3*@dirs+$descrlen;
233         $totalwidth += $_ for (@colwidth);
234
235         printf "%-${descrlen}s", "Test";
236         for my $i (0..$#dirs) {
237                 printf "   %-$colwidth[$i]s", display_dir($dirs[$i]);
238         }
239         print "\n";
240         print "-"x$totalwidth, "\n";
241         for my $t (@subtests) {
242                 printf "%-${descrlen}s", $descrs{$t};
243                 my $firstr;
244                 for my $i (0..$#dirs) {
245                         my $d = $dirs[$i];
246                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
247                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
248                         $firstr = $r unless defined $firstr;
249                 }
250                 print "\n";
251         }
252 }
253
254 sub print_sorted_results {
255         my ($sortby) = @_;
256
257         if ($sortby ne "regression") {
258                 print "Only 'regression' is supported as '--sort-by' argument\n";
259                 usage();
260         }
261
262         my @evolutions;
263         for my $t (@subtests) {
264                 my ($prevr, $prevu, $prevs, $prevrev);
265                 for my $i (0..$#dirs) {
266                         my $d = $dirs[$i];
267                         my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
268                         if ($i > 0 and defined $r and defined $prevr and $prevr > 0) {
269                                 my $percent = 100.0 * ($r - $prevr) / $prevr;
270                                 push @evolutions, { "percent"  => $percent,
271                                                     "test"     => $t,
272                                                     "prevrev"  => $prevrev,
273                                                     "rev"      => $d,
274                                                     "prevr"    => $prevr,
275                                                     "r"        => $r,
276                                                     "prevu"    => $prevu,
277                                                     "u"        => $u,
278                                                     "prevs"    => $prevs,
279                                                     "s"        => $s};
280                         }
281                         ($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d);
282                 }
283         }
284
285         my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions;
286
287         for my $e (@sorted_evolutions) {
288                 printf "%+.1f%%", $e->{percent};
289                 print " " . $e->{test};
290                 print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs});
291                 print " " . format_times($e->{r}, $e->{u}, $e->{s});
292                 print " " . display_dir($e->{prevrev});
293                 print " " . display_dir($e->{rev});
294                 print "\n";
295         }
296 }
297
298 sub print_codespeed_results {
299         my ($subsection) = @_;
300
301         my $project = "Git";
302
303         my $executable = `uname -s -m`;
304         chomp $executable;
305
306         if ($subsection) {
307                 $executable .= ", " . $subsection;
308         }
309
310         my $environment;
311         if ($reponame) {
312                 $environment = $reponame;
313         } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
314                 $environment = $ENV{GIT_PERF_REPO_NAME};
315         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
316                 $environment = $ENV{GIT_TEST_INSTALLED};
317                 $environment =~ s|/bin-wrappers$||;
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         print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
346 }
347
348 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
349
350 if ($codespeed) {
351         print_codespeed_results($subsection);
352 } elsif (defined $sortby) {
353         print_sorted_results($sortby);
354 } else {
355         print_default_results();
356 }