Merge branch 'cb/bash-completion-ls-files-processing'
[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 Git;
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         $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
21 sub 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
39 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
40     $codespeed, $sortby, $subsection, $reponame);
41 while (scalar @ARGV) {
42         my $arg = $ARGV[0];
43         my $dir;
44         if ($arg eq "--codespeed") {
45                 $codespeed = 1;
46                 shift @ARGV;
47                 next;
48         }
49         if ($arg =~ /--sort-by(?:=(.*))?/) {
50                 shift @ARGV;
51                 if (defined $1) {
52                         $sortby = $1;
53                 } else {
54                         $sortby = shift @ARGV;
55                         if (! defined $sortby) {
56                                 die "'--sort-by' requires an argument";
57                         }
58                 }
59                 next;
60         }
61         if ($arg eq "--subsection") {
62                 shift @ARGV;
63                 $subsection = $ARGV[0];
64                 shift @ARGV;
65                 if (! $subsection) {
66                         die "empty subsection";
67                 }
68                 next;
69         }
70         if ($arg eq "--reponame") {
71                 shift @ARGV;
72                 $reponame = $ARGV[0];
73                 shift @ARGV;
74                 if (! $reponame) {
75                         die "empty reponame";
76                 }
77                 next;
78         }
79         last if -f $arg or $arg eq "--";
80         if (! -d $arg) {
81                 my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
82                 $dir = "build/".$rev;
83         } else {
84                 $arg =~ s{/*$}{};
85                 $dir = $arg;
86                 $dirabbrevs{$dir} = $dir;
87         }
88         push @dirs, $dir;
89         $dirnames{$dir} = $arg;
90         my $prefix = $dir;
91         $prefix =~ tr/^a-zA-Z0-9/_/c;
92         $prefixes{$dir} = $prefix . '.';
93         shift @ARGV;
94 }
95
96 if (not @dirs) {
97         @dirs = ('.');
98 }
99 $dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
100 $prefixes{'.'} = '';
101
102 shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
103
104 @tests = @ARGV;
105 if (not @tests) {
106         @tests = glob "p????-*.sh";
107 }
108
109 my $resultsdir = "test-results";
110
111 if (! $subsection and
112     exists $ENV{GIT_PERF_SUBSECTION} and
113     $ENV{GIT_PERF_SUBSECTION} ne "") {
114         $subsection = $ENV{GIT_PERF_SUBSECTION};
115 }
116
117 if ($subsection) {
118         $resultsdir .= "/" . $subsection;
119 }
120
121 my @subtests;
122 my %shorttests;
123 for my $t (@tests) {
124         $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
125         my $n = $2;
126         my $fname = "$resultsdir/$t.subtests";
127         open my $fp, "<", $fname or die "cannot open $fname: $!";
128         for (<$fp>) {
129                 chomp;
130                 /^(\d+)$/ or die "malformed subtest line: $_";
131                 push @subtests, "$t.$1";
132                 $shorttests{"$t.$1"} = "$n.$1";
133         }
134         close $fp or die "cannot close $fname: $!";
135 }
136
137 sub read_descr {
138         my $name = shift;
139         open my $fh, "<", $name or return "<error reading description>";
140         binmode $fh, ":utf8" or die "PANIC on binmode: $!";
141         my $line = <$fh>;
142         close $fh or die "cannot close $name";
143         chomp $line;
144         return $line;
145 }
146
147 sub have_duplicate {
148         my %seen;
149         for (@_) {
150                 return 1 if exists $seen{$_};
151                 $seen{$_} = 1;
152         }
153         return 0;
154 }
155 sub have_slash {
156         for (@_) {
157                 return 1 if m{/};
158         }
159         return 0;
160 }
161
162 sub display_dir {
163         my ($d) = @_;
164         return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
165 }
166
167 sub print_default_results {
168         my %descrs;
169         my $descrlen = 4; # "Test"
170         for my $t (@subtests) {
171                 $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
172                 $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
173         }
174
175         my %newdirabbrevs = %dirabbrevs;
176         while (!have_duplicate(values %newdirabbrevs)) {
177                 %dirabbrevs = %newdirabbrevs;
178                 last if !have_slash(values %dirabbrevs);
179                 %newdirabbrevs = %dirabbrevs;
180                 for (values %newdirabbrevs) {
181                         s{^[^/]*/}{};
182                 }
183         }
184
185         my %times;
186         my @colwidth = ((0)x@dirs);
187         for my $i (0..$#dirs) {
188                 my $w = length display_dir($dirs[$i]);
189                 $colwidth[$i] = $w if $w > $colwidth[$i];
190         }
191         for my $t (@subtests) {
192                 my $firstr;
193                 for my $i (0..$#dirs) {
194                         my $d = $dirs[$i];
195                         $times{$prefixes{$d}.$t} = [get_times("$resultsdir/$prefixes{$d}$t.times")];
196                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
197                         my $w = length format_times($r,$u,$s,$firstr);
198                         $colwidth[$i] = $w if $w > $colwidth[$i];
199                         $firstr = $r unless defined $firstr;
200                 }
201         }
202         my $totalwidth = 3*@dirs+$descrlen;
203         $totalwidth += $_ for (@colwidth);
204
205         printf "%-${descrlen}s", "Test";
206         for my $i (0..$#dirs) {
207                 printf "   %-$colwidth[$i]s", display_dir($dirs[$i]);
208         }
209         print "\n";
210         print "-"x$totalwidth, "\n";
211         for my $t (@subtests) {
212                 printf "%-${descrlen}s", $descrs{$t};
213                 my $firstr;
214                 for my $i (0..$#dirs) {
215                         my $d = $dirs[$i];
216                         my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}};
217                         printf "   %-$colwidth[$i]s", format_times($r,$u,$s,$firstr);
218                         $firstr = $r unless defined $firstr;
219                 }
220                 print "\n";
221         }
222 }
223
224 sub print_sorted_results {
225         my ($sortby) = @_;
226
227         if ($sortby ne "regression") {
228                 die "only 'regression' is supported as '--sort-by' argument";
229         }
230
231         my @evolutions;
232         for my $t (@subtests) {
233                 my ($prevr, $prevu, $prevs, $prevrev);
234                 for my $i (0..$#dirs) {
235                         my $d = $dirs[$i];
236                         my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
237                         if ($i > 0 and defined $r and defined $prevr and $prevr > 0) {
238                                 my $percent = 100.0 * ($r - $prevr) / $prevr;
239                                 push @evolutions, { "percent"  => $percent,
240                                                     "test"     => $t,
241                                                     "prevrev"  => $prevrev,
242                                                     "rev"      => $d,
243                                                     "prevr"    => $prevr,
244                                                     "r"        => $r,
245                                                     "prevu"    => $prevu,
246                                                     "u"        => $u,
247                                                     "prevs"    => $prevs,
248                                                     "s"        => $s};
249                         }
250                         ($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d);
251                 }
252         }
253
254         my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions;
255
256         for my $e (@sorted_evolutions) {
257                 printf "%+.1f%%", $e->{percent};
258                 print " " . $e->{test};
259                 print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs});
260                 print " " . format_times($e->{r}, $e->{u}, $e->{s});
261                 print " " . display_dir($e->{prevrev});
262                 print " " . display_dir($e->{rev});
263                 print "\n";
264         }
265 }
266
267 sub print_codespeed_results {
268         my ($subsection) = @_;
269
270         my $project = "Git";
271
272         my $executable = `uname -s -m`;
273         chomp $executable;
274
275         if ($subsection) {
276                 $executable .= ", " . $subsection;
277         }
278
279         my $environment;
280         if ($reponame) {
281                 $environment = $reponame;
282         } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") {
283                 $environment = $ENV{GIT_PERF_REPO_NAME};
284         } elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
285                 $environment = $ENV{GIT_TEST_INSTALLED};
286                 $environment =~ s|/bin-wrappers$||;
287         } else {
288                 $environment = `uname -r`;
289                 chomp $environment;
290         }
291
292         my @data;
293
294         for my $t (@subtests) {
295                 for my $d (@dirs) {
296                         my $commitid = $prefixes{$d};
297                         $commitid =~ s/^build_//;
298                         $commitid =~ s/\.$//;
299                         my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.times");
300
301                         my %vals = (
302                                 "commitid" => $commitid,
303                                 "project" => $project,
304                                 "branch" => $dirnames{$d},
305                                 "executable" => $executable,
306                                 "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"),
307                                 "environment" => $environment,
308                                 "result_value" => $result_value,
309                             );
310                         push @data, \%vals;
311                 }
312         }
313
314         print to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n";
315 }
316
317 binmode STDOUT, ":utf8" or die "PANIC on binmode: $!";
318
319 if ($codespeed) {
320         print_codespeed_results($subsection);
321 } elsif (defined $sortby) {
322         print_sorted_results($sortby);
323 } else {
324         print_default_results();
325 }