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