1#!/usr/local/bin/perl
2
3use lib '../../perl/build/lib';
4use strict;
5use warnings;
6use Getopt::Long;
7use Cwd qw(realpath);
8
9sub 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 =~ /^\s*(\d+)$/) {
21		return $1;
22	} else {
23		die "bad input line: $line";
24	}
25}
26
27sub 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
38sub 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
54sub 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    --results-dir <str>  * Directory where test results are located
62    --sort-by     <str>  * Sort output (only "regression" criteria is supported)
63    --subsection  <str>  * Use results from given subsection
64
65EOT
66	exit(1);
67}
68
69sub 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
80sub 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
88sub sane_backticks {
89	open(my $fh, '-|', @_);
90	return <$fh>;
91}
92
93my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
94    $codespeed, $sortby, $subsection, $reponame);
95my $resultsdir = "test-results";
96
97Getopt::Long::Configure qw/ require_order /;
98
99my $rc = GetOptions("codespeed"     => \$codespeed,
100		    "reponame=s"    => \$reponame,
101		    "results-dir=s" => \$resultsdir,
102		    "sort-by=s"     => \$sortby,
103		    "subsection=s"  => \$subsection);
104usage() unless $rc;
105
106while (scalar @ARGV) {
107	my $arg = $ARGV[0];
108	my $dir;
109	my $prefix = '';
110	last if -f $arg or $arg eq "--";
111	if (! -d $arg) {
112		my $rev = sane_backticks(qw(git rev-parse --verify), $arg);
113		chomp $rev;
114		$dir = "build/".$rev;
115	} elsif ($arg eq '.') {
116		$dir = '.';
117	} else {
118		$dir = realpath($arg);
119		$dirnames{$dir} = $dir;
120		$prefix .= 'bindir';
121	}
122	push @dirs, $dir;
123	$dirnames{$dir} ||= $arg;
124	$prefix .= $dir;
125	$prefix =~ tr/^a-zA-Z0-9/_/c;
126	$prefixes{$dir} = $prefix . '.';
127	shift @ARGV;
128}
129
130if (not @dirs) {
131	@dirs = ('.');
132}
133$dirnames{'.'} = $dirabbrevs{'.'} = "this tree";
134$prefixes{'.'} = '';
135
136shift @ARGV if scalar @ARGV and $ARGV[0] eq "--";
137
138@tests = @ARGV;
139if (not @tests) {
140	@tests = glob "p????-*.sh";
141}
142
143if (! $subsection and
144    exists $ENV{GIT_PERF_SUBSECTION} and
145    $ENV{GIT_PERF_SUBSECTION} ne "") {
146	$subsection = $ENV{GIT_PERF_SUBSECTION};
147}
148
149if ($subsection) {
150	$resultsdir .= "/" . $subsection;
151}
152
153my @subtests;
154my %shorttests;
155for my $t (@tests) {
156	$t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t";
157	my $n = $2;
158	my $fname = "$resultsdir/$t.subtests";
159	open my $fp, "<", $fname or die "cannot open $fname: $!";
160	for (<$fp>) {
161		chomp;
162		/^(\d+)$/ or die "malformed subtest line: $_";
163		push @subtests, "$t.$1";
164		$shorttests{"$t.$1"} = "$n.$1";
165	}
166	close $fp or die "cannot close $fname: $!";
167}
168
169sub read_descr {
170	my $name = shift;
171	open my $fh, "<", $name or return "<error reading description>";
172	binmode $fh, ":utf8" or die "PANIC on binmode: $!";
173	my $line = <$fh>;
174	close $fh or die "cannot close $name";
175	chomp $line;
176	return $line;
177}
178
179sub have_duplicate {
180	my %seen;
181	for (@_) {
182		return 1 if exists $seen{$_};
183		$seen{$_} = 1;
184	}
185	return 0;
186}
187sub have_slash {
188	for (@_) {
189		return 1 if m{/};
190	}
191	return 0;
192}
193
194sub display_dir {
195	my ($d) = @_;
196	return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d};
197}
198
199sub print_default_results {
200	my %descrs;
201	my $descrlen = 4; # "Test"
202	for my $t (@subtests) {
203		$descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr");
204		$descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen;
205	}
206
207	my %newdirabbrevs = %dirabbrevs;
208	while (!have_duplicate(values %newdirabbrevs)) {
209		%dirabbrevs = %newdirabbrevs;
210		last if !have_slash(values %dirabbrevs);
211		%newdirabbrevs = %dirabbrevs;
212		for (values %newdirabbrevs) {
213			s{^[^/]*/}{};
214		}
215	}
216
217	my %times;
218	my @colwidth = ((0)x@dirs);
219	for my $i (0..$#dirs) {
220		my $w = length display_dir($dirs[$i]);
221		$colwidth[$i] = $w if $w > $colwidth[$i];
222	}
223	for my $t (@subtests) {
224		my $firstr;
225		for my $i (0..$#dirs) {
226			my $d = $dirs[$i];
227			my $base = "$resultsdir/$prefixes{$d}$t";
228			$times{$prefixes{$d}.$t} = [get_times("$base.result")];
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
257sub 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.result");
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
301sub 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.result");
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
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}
358