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