freshlybakedca.ke
Git fork
1#!/usr/bin/env 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}