#!/usr/bin/perl use lib '../../perl/build/lib'; use strict; use warnings; use Getopt::Long; use Cwd qw(realpath); sub get_times { my $name = shift; open my $fh, "<", $name or return undef; my $line = <$fh>; return undef if not defined $line; close $fh or die "cannot close $name: $!"; # times if ($line =~ /^(?:(\d+):)?(\d+):(\d+(?:\.\d+)?) (\d+(?:\.\d+)?) (\d+(?:\.\d+)?)$/) { my $rt = ((defined $1 ? $1 : 0.0)*60+$2)*60+$3; return ($rt, $4, $5); # size } elsif ($line =~ /^\s*(\d+)$/) { return $1; } else { die "bad input line: $line"; } } sub relative_change { my ($r, $firstr) = @_; if ($firstr > 0) { return sprintf "%+.1f%%", 100.0*($r-$firstr)/$firstr; } elsif ($r == 0) { return "="; } else { return "+inf"; } } sub format_times { my ($r, $u, $s, $firstr) = @_; # no value means we did not finish the test if (!defined $r) { return "<missing>"; } # a single value means we have a size, not times if (!defined $u) { return format_size($r, $firstr); } # otherwise, we have real/user/system times my $out = sprintf "%.2f(%.2f+%.2f)", $r, $u, $s; $out .= ' ' . relative_change($r, $firstr) if defined $firstr; return $out; } sub usage { print <<EOT; ./aggregate.perl [options] [--] [<dir_or_rev>...] [--] [<test_script>...] > Options: --codespeed * Format output for Codespeed --reponame <str> * Send given reponame to codespeed --results-dir <str> * Directory where test results are located --sort-by <str> * Sort output (only "regression" criteria is supported) --subsection <str> * Use results from given subsection EOT exit(1); } sub human_size { my $n = shift; my @units = ('', qw(K M G)); while ($n > 900 && @units > 1) { $n /= 1000; shift @units; } return $n unless length $units[0]; return sprintf '%.1f%s', $n, $units[0]; } sub format_size { my ($size, $first) = @_; # match the width of a time: 0.00(0.00+0.00) my $out = sprintf '%15s', human_size($size); $out .= ' ' . relative_change($size, $first) if defined $first; return $out; } sub sane_backticks { open(my $fh, '-|', @_); return <$fh>; } my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests, $codespeed, $sortby, $subsection, $reponame); my $resultsdir = "test-results"; Getopt::Long::Configure qw/ require_order /; my $rc = GetOptions("codespeed" => \$codespeed, "reponame=s" => \$reponame, "results-dir=s" => \$resultsdir, "sort-by=s" => \$sortby, "subsection=s" => \$subsection); usage() unless $rc; while (scalar @ARGV) { my $arg = $ARGV[0]; my $dir; my $prefix = ''; last if -f $arg or $arg eq "--"; if (! -d $arg) { my $rev = sane_backticks(qw(git rev-parse --verify), $arg); chomp $rev; $dir = "build/".$rev; } elsif ($arg eq '.') { $dir = '.'; } else { $dir = realpath($arg); $dirnames{$dir} = $dir; $prefix .= 'bindir'; } push @dirs, $dir; $dirnames{$dir} ||= $arg; $prefix .= $dir; $prefix =~ tr/^a-zA-Z0-9/_/c; $prefixes{$dir} = $prefix . '.'; shift @ARGV; } if (not @dirs) { @dirs = ('.'); } $dirnames{'.'} = $dirabbrevs{'.'} = "this tree"; $prefixes{'.'} = ''; shift @ARGV if scalar @ARGV and $ARGV[0] eq "--"; @tests = @ARGV; if (not @tests) { @tests = glob "p????-*.sh"; } if (! $subsection and exists $ENV{GIT_PERF_SUBSECTION} and $ENV{GIT_PERF_SUBSECTION} ne "") { $subsection = $ENV{GIT_PERF_SUBSECTION}; } if ($subsection) { $resultsdir .= "/" . $subsection; } my @subtests; my %shorttests; for my $t (@tests) { $t =~ s{(?:.*/)?(p(\d+)-[^/]+)\.sh$}{$1} or die "bad test name: $t"; my $n = $2; my $fname = "$resultsdir/$t.subtests"; open my $fp, "<", $fname or die "cannot open $fname: $!"; for (<$fp>) { chomp; /^(\d+)$/ or die "malformed subtest line: $_"; push @subtests, "$t.$1"; $shorttests{"$t.$1"} = "$n.$1"; } close $fp or die "cannot close $fname: $!"; } sub read_descr { my $name = shift; open my $fh, "<", $name or return "<error reading description>"; binmode $fh, ":utf8" or die "PANIC on binmode: $!"; my $line = <$fh>; close $fh or die "cannot close $name"; chomp $line; return $line; } sub have_duplicate { my %seen; for (@_) { return 1 if exists $seen{$_}; $seen{$_} = 1; } return 0; } sub have_slash { for (@_) { return 1 if m{/}; } return 0; } sub display_dir { my ($d) = @_; return exists $dirabbrevs{$d} ? $dirabbrevs{$d} : $dirnames{$d}; } sub print_default_results { my %descrs; my $descrlen = 4; # "Test" for my $t (@subtests) { $descrs{$t} = $shorttests{$t}.": ".read_descr("$resultsdir/$t.descr"); $descrlen = length $descrs{$t} if length $descrs{$t}>$descrlen; } my %newdirabbrevs = %dirabbrevs; while (!have_duplicate(values %newdirabbrevs)) { %dirabbrevs = %newdirabbrevs; last if !have_slash(values %dirabbrevs); %newdirabbrevs = %dirabbrevs; for (values %newdirabbrevs) { s{^[^/]*/}{}; } } my %times; my @colwidth = ((0)x@dirs); for my $i (0..$#dirs) { my $w = length display_dir($dirs[$i]); $colwidth[$i] = $w if $w > $colwidth[$i]; } for my $t (@subtests) { my $firstr; for my $i (0..$#dirs) { my $d = $dirs[$i]; my $base = "$resultsdir/$prefixes{$d}$t"; $times{$prefixes{$d}.$t} = [get_times("$base.result")]; my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}}; my $w = length format_times($r,$u,$s,$firstr); $colwidth[$i] = $w if $w > $colwidth[$i]; $firstr = $r unless defined $firstr; } } my $totalwidth = 3*@dirs+$descrlen; $totalwidth += $_ for (@colwidth); printf "%-${descrlen}s", "Test"; for my $i (0..$#dirs) { printf " %-$colwidth[$i]s", display_dir($dirs[$i]); } print "\n"; print "-"x$totalwidth, "\n"; for my $t (@subtests) { printf "%-${descrlen}s", $descrs{$t}; my $firstr; for my $i (0..$#dirs) { my $d = $dirs[$i]; my ($r,$u,$s) = @{$times{$prefixes{$d}.$t}}; printf " %-$colwidth[$i]s", format_times($r,$u,$s,$firstr); $firstr = $r unless defined $firstr; } print "\n"; } } sub print_sorted_results { my ($sortby) = @_; if ($sortby ne "regression") { print "Only 'regression' is supported as '--sort-by' argument\n"; usage(); } my @evolutions; for my $t (@subtests) { my ($prevr, $prevu, $prevs, $prevrev); for my $i (0..$#dirs) { my $d = $dirs[$i]; my ($r, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.result"); if ($i > 0 and defined $r and defined $prevr and $prevr > 0) { my $percent = 100.0 * ($r - $prevr) / $prevr; push @evolutions, { "percent" => $percent, "test" => $t, "prevrev" => $prevrev, "rev" => $d, "prevr" => $prevr, "r" => $r, "prevu" => $prevu, "u" => $u, "prevs" => $prevs, "s" => $s}; } ($prevr, $prevu, $prevs, $prevrev) = ($r, $u, $s, $d); } } my @sorted_evolutions = sort { $b->{percent} <=> $a->{percent} } @evolutions; for my $e (@sorted_evolutions) { printf "%+.1f%%", $e->{percent}; print " " . $e->{test}; print " " . format_times($e->{prevr}, $e->{prevu}, $e->{prevs}); print " " . format_times($e->{r}, $e->{u}, $e->{s}); print " " . display_dir($e->{prevrev}); print " " . display_dir($e->{rev}); print "\n"; } } sub print_codespeed_results { my ($subsection) = @_; my $project = "Git"; my $executable = `uname -s -m`; chomp $executable; if ($subsection) { $executable .= ", " . $subsection; } my $environment; if ($reponame) { $environment = $reponame; } elsif (exists $ENV{GIT_PERF_REPO_NAME} and $ENV{GIT_PERF_REPO_NAME} ne "") { $environment = $ENV{GIT_PERF_REPO_NAME}; } else { $environment = `uname -r`; chomp $environment; } my @data; for my $t (@subtests) { for my $d (@dirs) { my $commitid = $prefixes{$d}; $commitid =~ s/^build_//; $commitid =~ s/\.$//; my ($result_value, $u, $s) = get_times("$resultsdir/$prefixes{$d}$t.result"); my %vals = ( "commitid" => $commitid, "project" => $project, "branch" => $dirnames{$d}, "executable" => $executable, "benchmark" => $shorttests{$t} . " " . read_descr("$resultsdir/$t.descr"), "environment" => $environment, "result_value" => $result_value, ); push @data, \%vals; } } require JSON; print JSON::to_json(\@data, {utf8 => 1, pretty => 1, canonical => 1}), "\n"; } binmode STDOUT, ":utf8" or die "PANIC on binmode: $!"; if ($codespeed) { print_codespeed_results($subsection); } elsif (defined $sortby) { print_sorted_results($sortby); } else { print_default_results(); }