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