summaryrefslogtreecommitdiffstats
path: root/t/perf/aggregate.perl
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:47:53 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 14:47:53 +0000
commitc8bae7493d2f2910b57f13ded012e86bdcfb0532 (patch)
tree24e09d9f84dec336720cf393e156089ca2835791 /t/perf/aggregate.perl
parentInitial commit. (diff)
downloadgit-c8bae7493d2f2910b57f13ded012e86bdcfb0532.tar.xz
git-c8bae7493d2f2910b57f13ded012e86bdcfb0532.zip
Adding upstream version 1:2.39.2.upstream/1%2.39.2upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 't/perf/aggregate.perl')
-rwxr-xr-xt/perf/aggregate.perl357
1 files changed, 357 insertions, 0 deletions
diff --git a/t/perf/aggregate.perl b/t/perf/aggregate.perl
new file mode 100755
index 0000000..575d200
--- /dev/null
+++ b/t/perf/aggregate.perl
@@ -0,0 +1,357 @@
+#!/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();
+}