diff options
author | Vincent Ambo <mail@tazj.in> | 2021-09-21T10·03+0300 |
---|---|---|
committer | Vincent Ambo <mail@tazj.in> | 2021-09-21T11·29+0300 |
commit | 43b1791ec601732ac31195df96781a848360a9ac (patch) | |
tree | daae8d638343295d2f1f7da955e556ef4c958864 /third_party/git/t/perf/aggregate.perl | |
parent | 2d8e7dc9d9c38127ec4ebd13aee8e8f586a43318 (diff) |
chore(3p/git): Unvendor git and track patches instead r/2903
This was vendored a long time ago under the expectation that keeping it in sync with cgit would be easier this way, but it has proven not to be a big issue. On the other hand, a vendored copy of git is an annoying maintenance burden. It is much easier to rebase the single (dottime) patch that we have. This removes the vendored copy of git and instead passes the git source code to cgit via `pkgs.srcOnly`, which includes the applied patch so that cgit can continue rendering dottime. Change-Id: If31f62dea7ce688fd1b9050204e9378019775f2b
Diffstat (limited to 'third_party/git/t/perf/aggregate.perl')
-rwxr-xr-x | third_party/git/t/perf/aggregate.perl | 356 |
1 files changed, 0 insertions, 356 deletions
diff --git a/third_party/git/t/perf/aggregate.perl b/third_party/git/t/perf/aggregate.perl deleted file mode 100755 index 14e4cda287d7..000000000000 --- a/third_party/git/t/perf/aggregate.perl +++ /dev/null @@ -1,356 +0,0 @@ -#!/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 =~ /^\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; -} - -sub sane_backticks { - open(my $fh, '-|', @_); - return <$fh>; -} - -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; - 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"; -} - -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} = [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(); -} |