t/perf/aggregate.perl - git - Git at Google

 #!/usr/bin/perl

 use lib '../../perl/build/lib';
 use strict;
 use warnings;
 use JSON;
 use Getopt::Long;
 use Git;

 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 =~ /^\d+$/) {
 		return $&;
 	} 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
     --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;
 }

 my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
     $codespeed, $sortby, $subsection, $reponame);

 Getopt::Long::Configure qw/ require_order /;

 my $rc = GetOptions("codespeed"     => \$codespeed,
 		    "reponame=s"    => \$reponame,
 		    "sort-by=s"     => \$sortby,
 		    "subsection=s"  => \$subsection);
 usage() unless $rc;

 while (scalar @ARGV) {
 	my $arg = $ARGV[0];
 	my $dir;
 	last if -f $arg or $arg eq "--";
 	if (! -d $arg) {
 		my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
 		$dir = "build/".$rev;
 	} else {
 		$arg =~ s{/*$}{};
 		$dir = $arg;
 		$dirabbrevs{$dir} = $dir;
 	}
 	push @dirs, $dir;
 	$dirnames{$dir} = $arg;
 	my $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";
 }

 my $resultsdir = "test-results";

 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} = [];
 			foreach my $type (qw(times size)) {
 				if (-e "$base.$type") {
 					$times{$prefixes{$d}.$t} = [get_times("$base.$type")];
 					last;
 				}
 			}
 			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.times");
 			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};
 	} elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
 		$environment = $ENV{GIT_TEST_INSTALLED};
 		$environment =~ s|/bin-wrappers$||;
 	} 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.times");

 			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;
 		}
 	}

 	print 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();
 }
	#!/usr/bin/perl

	use lib '../../perl/build/lib';
	use strict;
	use warnings;
	use JSON;
	use Getopt::Long;
	use Git;

	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 =~ /^\d+$/) {
	return $&;
	} 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
	--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;
	}

	my (@dirs, %dirnames, %dirabbrevs, %prefixes, @tests,
	$codespeed, $sortby, $subsection, $reponame);

	Getopt::Long::Configure qw/ require_order /;

	my $rc = GetOptions("codespeed" => \$codespeed,
	"reponame=s" => \$reponame,
	"sort-by=s" => \$sortby,
	"subsection=s" => \$subsection);
	usage() unless $rc;

	while (scalar @ARGV) {
	my $arg = $ARGV[0];
	my $dir;
	last if -f $arg or $arg eq "--";
	if (! -d $arg) {
	my $rev = Git::command_oneline(qw(rev-parse --verify), $arg);
	$dir = "build/".$rev;
	} else {
	$arg =~ s{/*$}{};
	$dir = $arg;
	$dirabbrevs{$dir} = $dir;
	}
	push @dirs, $dir;
	$dirnames{$dir} = $arg;
	my $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";
	}

	my $resultsdir = "test-results";

	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} = [];
	foreach my $type (qw(times size)) {
	if (-e "$base.$type") {
	$times{$prefixes{$d}.$t} = [get_times("$base.$type")];
	last;
	}
	}
	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.times");
	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};
	} elsif (exists $ENV{GIT_TEST_INSTALLED} and $ENV{GIT_TEST_INSTALLED} ne "") {
	$environment = $ENV{GIT_TEST_INSTALLED};
	$environment =~ s\|/bin-wrappers$\|\|;
	} 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.times");

	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;
	}
	}

	print 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();
	}