mirror of
https://sourceware.org/git/binutils-gdb.git
synced 2024-12-27 04:52:05 +08:00
bb368aad29
top-level * Makefile.def: Add gprofng module. * configure.ac: Add --enable-gprofng option. * src-release.sh: Add gprofng. * Makefile.in: Regenerate. * configure: Regenerate. * gprofng: New directory. binutils * MAINTAINERS: Add gprofng maintainer. * README-how-to-make-a-release: Add gprofng. include. * collectorAPI.h: New file. * libcollector.h: New file. * libfcollector.h: New file.
775 lines
22 KiB
Perl
775 lines
22 KiB
Perl
# Copyright (C) 2021 Free Software Foundation, Inc.
|
|
#
|
|
# This file is part of the GNU Binutils.
|
|
#
|
|
# This file is free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program; if not, write to the Free Software
|
|
# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston,
|
|
# MA 02110-1301, USA.
|
|
|
|
use strict;
|
|
package acct;
|
|
use vars qw(%Acct $Erp);
|
|
my($debug_f, $retVal, $OpenDis, $OpenFsingle, $Read_rules_txt);
|
|
my(@Comparison, @hashSample, @acctHeader);
|
|
my(%RANGE, %Rules);
|
|
my($ERROR_ACCT_MISMATCH, $ERROR_NEGATIVE_TIME, $ERROR_PERL_ERROR,
|
|
$ERROR_DIFF_RANGE, $ERROR_ZERO_METRIC, $ERROR_HIGH_UNKNOWN,
|
|
$ERROR_CALLER_VERIF, $ERROR_SIGNAL_LOST);
|
|
|
|
BEGIN {
|
|
# use Exporter ();
|
|
# @ISA = 'Exporter';
|
|
# @EXPORT_OK = ('&readAcct', '%Acct');
|
|
$debug_f = $ENV{PERL_DEBUG};
|
|
$retVal = 0;
|
|
$OpenDis = 0;
|
|
$OpenFsingle = 0;
|
|
$#Comparison = -1;
|
|
$Read_rules_txt = 0;
|
|
$Erp = {};
|
|
@hashSample = [];
|
|
|
|
%RANGE = (
|
|
Count => { P_RANGE => 0, P_RATE => 0,
|
|
N_RANGE => 0, N_RATE => 0, FMT => "%d"
|
|
},
|
|
Total => { P_RANGE => 0.20, P_RATE => 3,
|
|
N_RANGE => -0.20, N_RATE => -3, FMT => "%6.3f"
|
|
},
|
|
Cpu => { P_RANGE => 0.5, P_RATE => 10,
|
|
N_RANGE => -0.5, N_RATE => -10, FMT => "%6.3f"
|
|
,P_RANGE_2AVG => 0.5, P_RATE_2AVG => 10,
|
|
N_RANGE_2AVG => -0.5, N_RATE_2AVG => -10
|
|
},
|
|
Cycles => { P_RANGE => 0.5, P_RATE => 10,
|
|
N_RANGE => -0.5, N_RATE => -10, FMT => "%6.3f"
|
|
,P_RANGE_2AVG => 0.5, P_RATE_2AVG => 10,
|
|
N_RANGE_2AVG => -0.5, N_RATE_2AVG => -10
|
|
},
|
|
Cycles1 => { P_RANGE => 0.5, P_RATE => 10,
|
|
N_RANGE => -0.5, N_RATE => -10, FMT => "%6.3f"
|
|
,P_RANGE_2AVG => 0.5, P_RATE_2AVG => 10,
|
|
N_RANGE_2AVG => -0.5, N_RATE_2AVG => -10
|
|
},
|
|
Sync => { P_RANGE => 0.5, P_RATE => 3,
|
|
N_RANGE => -0.5, N_RATE => -3, FMT => "%6.3f"
|
|
},
|
|
Unkn => { P_RANGE => 0.10, P_RATE => 0.5, FMT => "%6.3f" }
|
|
);
|
|
|
|
$ERROR_SIGNAL_LOST = 44;
|
|
$ERROR_DIFF_RANGE = 84;
|
|
$ERROR_HIGH_UNKNOWN = 85;
|
|
$ERROR_PERL_ERROR = 86;
|
|
$ERROR_ACCT_MISMATCH = 87;
|
|
$ERROR_CALLER_VERIF = 88;
|
|
$ERROR_ZERO_METRIC = 94;
|
|
$ERROR_NEGATIVE_TIME = 103;
|
|
}
|
|
|
|
sub debug
|
|
{
|
|
my ($lineN, $fmt);
|
|
if ( $debug_f == 0 ) {
|
|
return;
|
|
}
|
|
$lineN = shift @_;
|
|
$fmt = shift @_;
|
|
if ( $debug_f == 2 ) {
|
|
warn "DEBUG:#$lineN:\n";
|
|
}
|
|
warn sprintf($fmt, @_);
|
|
}
|
|
|
|
sub set_retVal
|
|
{
|
|
if ( $retVal == 0 ) {
|
|
$retVal = $_[0];
|
|
if ($retVal != 0 ) {
|
|
warn sprintf("DEBUG: retVal=%d\n", $retVal);
|
|
}
|
|
}
|
|
return $retVal;
|
|
}
|
|
|
|
sub diffRule
|
|
{
|
|
# The format of the comparison rule is:
|
|
# <Name>, <Column number in *.acct>, <Column number in erprint.out>, <message>
|
|
# Cpu, 3, 1
|
|
# Total, 2, 3
|
|
my ($str) = @_;
|
|
my (@arr);
|
|
|
|
@arr = split (/,/, $str);
|
|
if ($#arr == 2) {
|
|
# Old version
|
|
push @arr, $arr[0];
|
|
}
|
|
push @Comparison, [@arr];
|
|
}
|
|
|
|
sub read_rules
|
|
{
|
|
my ($name, $rule, $line, @arr);
|
|
return if ( $Read_rules_txt == 1);
|
|
$Read_rules_txt = 1;
|
|
open(FP, "<rules.txt") or return;
|
|
while ($line = <FP>) {
|
|
chomp ($line);
|
|
$line =~ s/\s*//g; # Remove all blanks
|
|
$line =~ s/\\s/ /g; # Replace \s with space
|
|
next if ( $line =~ m/^$/ );
|
|
next if ( $line =~ m/^#/ );
|
|
|
|
if ( $line =~ m/=/ ) {
|
|
# Set a calculation rule
|
|
($name, $rule) = split (/=/, $line);
|
|
$Rules{$name} = [split(/\+/, $rule)];
|
|
next;
|
|
}
|
|
|
|
# Set a comparison rule
|
|
&diffRule($line);
|
|
}
|
|
close(FP);
|
|
}
|
|
|
|
sub dump_acct()
|
|
{
|
|
my ($i, $n, $key, $fmt, @fmt_head);
|
|
printf "dump_acct:\n";
|
|
foreach $i ( @acctHeader ) {
|
|
$fmt = sprintf("%%%ds ", length($i));
|
|
push @fmt_head, $fmt;
|
|
printf $fmt, $i;
|
|
}
|
|
printf "\n";
|
|
foreach $key (sort keys %Acct) {
|
|
$n = 0;
|
|
foreach $i ( @{$Acct{$key}} ) {
|
|
$fmt = $n <= $#fmt_head ? $fmt_head[$n] : " %10s";
|
|
$n++;
|
|
printf $fmt, $i;
|
|
}
|
|
printf " '%s'", $key;
|
|
if ( exists $Rules{$key} ) {
|
|
printf " := %s", join(" + ", @{$Rules{$key}});
|
|
}
|
|
printf "\n";
|
|
}
|
|
}
|
|
|
|
sub readAcct
|
|
{
|
|
# Read the *.acct file into hash $Acct with the function name as key.
|
|
# The format of *.acct is :
|
|
# X <time1> ... <timeN> <func_name>
|
|
my ($fileName, @checkTime) = @_;
|
|
my ($name, $i, $key, $line, @arr);
|
|
|
|
# file *.acct is generated while the test program is running.
|
|
if (!open(FP, "<$fileName")) {
|
|
printf "acct::readAcct: Cannot open '%s'\n\n", $fileName;
|
|
exit($ERROR_ACCT_MISMATCH);
|
|
}
|
|
while ($line = <FP>) { # Skip the first lines (header)
|
|
last if ( $line =~ m/^X\s+/ );
|
|
}
|
|
@acctHeader = split (/\s+/, $line);
|
|
push @acctHeader, "Comment";
|
|
while ($line = <FP>) {
|
|
chomp($line);
|
|
$line =~ s/^\s*//; # Delete leading spaces
|
|
next if ( $line =~ m/^$/ );
|
|
@arr = split (/\s+/, $line);
|
|
$name = pop(@arr);
|
|
if (defined $Acct{$name}) {
|
|
for ($i = 1; $i <= $#arr; $i++ ) {
|
|
$Acct{$name}[$i] += $arr[$i];
|
|
}
|
|
} else {
|
|
$Acct{$name} = [ @arr ];
|
|
}
|
|
|
|
foreach $i ( @checkTime ) {
|
|
next if ($i > $#arr);
|
|
if ( $arr[$i] < 0 ) {
|
|
&set_retVal($ERROR_NEGATIVE_TIME);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
close(FP);
|
|
|
|
&read_rules;
|
|
# &checkCallersCallees;
|
|
|
|
if ( $debug_f != 0 ) {
|
|
printf "\nreadAcct: '%s'\n", $fileName;
|
|
printf "checkTime: ";
|
|
if( $#checkTime == -1 ) {
|
|
printf "<None>\n";
|
|
} else {
|
|
print "[ ", join(", ", @checkTime), " ]\n";
|
|
}
|
|
foreach $i ( @Comparison ) {
|
|
print "Comparison rule: ", join(", ", @{$i}), "\n";
|
|
}
|
|
&dump_acct;
|
|
printf "\n";
|
|
}
|
|
}
|
|
|
|
|
|
sub read_er_print_out
|
|
{
|
|
my ($fileName, $colName) = @_;
|
|
my ($name, @arr, $head_f, $line, $key, $i);
|
|
|
|
$Erp = {};
|
|
$head_f = 1;
|
|
open(FP, "<$fileName") or return;
|
|
while ($line = <FP>) {
|
|
chomp($line);
|
|
$line =~ s/^\s*//; # Delete leading spaces
|
|
next if ( $line =~ m/^$/ );
|
|
if ($head_f == 1) {
|
|
# Skip the first lines (header)
|
|
next unless ( $line =~ m/^\d/ );
|
|
next unless ( ($line =~ m/<Total>\s*$/) ||
|
|
($line =~ m/<Stack-unwind-failed>\s*$/) );
|
|
$head_f = 0;
|
|
if ($colName == -1) {
|
|
@arr = split (/\s+/, $line);
|
|
$colName = $#arr + 1;
|
|
}
|
|
}
|
|
@arr = split (/\s+/, $line, $colName);
|
|
$name = pop(@arr);
|
|
if (defined $Erp->{$name}) {
|
|
for ($i = 0; $i <= $#arr; $i++ ) {
|
|
$Erp->{$name}[$i] += $arr[$i];
|
|
}
|
|
} else {
|
|
$Erp->{$name} = [ @arr ];
|
|
}
|
|
|
|
$i = index($name, "(");
|
|
if ($i > 0) {
|
|
my $funcName = substr($name, 0, $i);
|
|
if (defined $Erp->{$funcName}) {
|
|
for ($i = 0; $i <= $#arr; $i++ ) {
|
|
$Erp->{$funcName}[$i] += $arr[$i];
|
|
}
|
|
} else {
|
|
$Erp->{$funcName} = [ @arr ];
|
|
}
|
|
}
|
|
}
|
|
close(FP);
|
|
|
|
if ( $debug_f != 0 ) {
|
|
printf "read_er_print_out:\n";
|
|
foreach $key (sort keys %{$Erp}) {
|
|
foreach $i ( @{$Erp->{$key}} ) {
|
|
printf " %10s", $i;
|
|
}
|
|
printf " %-10s", "'$key'";
|
|
if ( exists $Rules{$key} ) {
|
|
printf " += %s", join(" + ", @{$Rules{$key}});
|
|
}
|
|
printf "\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
sub createKDiff
|
|
{
|
|
my ($colSample) = @_;
|
|
my ($key, $str, $i, $head_str);
|
|
|
|
open(DIFF_fp, ">diff.out");
|
|
$head_str = "X";
|
|
for $i ( 0..$#Comparison ) {
|
|
$head_str .= &get_head_str($i);
|
|
}
|
|
$head_str .= " Name";
|
|
printf DIFF_fp "%s\n", $head_str;
|
|
foreach $key (sort keys %Acct) {
|
|
# Restore a hash 'Erp'
|
|
$Erp = $hashSample[$Acct{$key}[$colSample]];
|
|
$str = &doComp($key, $head_str);
|
|
printf DIFF_fp "%s (Sample %d)\n", $str,$Acct{$key}[$colSample];
|
|
}
|
|
close(DIFF_fp);
|
|
&closeDisFile();
|
|
}
|
|
|
|
sub commandToScr1_fp()
|
|
{
|
|
my ($str) = @_;
|
|
printf Scr1_fp "#\n#%s\n%s\n", $str, $str;
|
|
}
|
|
|
|
sub openFsingleScr
|
|
{
|
|
return if ($OpenFsingle == 1);
|
|
open(Scr1_fp, ">>erp_fsingle.scr");
|
|
$OpenFsingle = 1;
|
|
}
|
|
|
|
sub closeFsingleScr
|
|
{
|
|
return if ($OpenFsingle != 1);
|
|
$OpenFsingle = 2;
|
|
close(Scr1_fp);
|
|
}
|
|
|
|
sub openDisFile
|
|
{
|
|
&openFsingleScr();
|
|
return if ($OpenDis == 1);
|
|
open(Dis_fp, ">>discrepancy.out");
|
|
$OpenDis = 1;
|
|
}
|
|
|
|
sub closeDisFile
|
|
{
|
|
&closeFsingleScr();
|
|
return if ($OpenDis != 1);
|
|
$OpenDis = 2;
|
|
close(Dis_fp);
|
|
}
|
|
|
|
sub with_diff
|
|
{
|
|
my ($i) = @_;
|
|
my ($key);
|
|
|
|
$key = $Comparison[$i][0];
|
|
if( ! exists $RANGE{$key} ) {
|
|
printf "acct::with_diff: '$key' is a wrong key\n\n";
|
|
exit $ERROR_PERL_ERROR;
|
|
}
|
|
if ($RANGE{$key}->{FMT} !~ m/^%d/) {
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub get_head_str()
|
|
{
|
|
my ($i) = @_;
|
|
my ($str);
|
|
$str = $Comparison[$i][3];
|
|
while (length($str) < 16) {
|
|
$str = "*" . $str . "*";
|
|
}
|
|
if (with_diff($i)) {
|
|
return sprintf("| %17s %7s %7s %s", $str, "Diff", "%", "x");
|
|
} else {
|
|
return sprintf("| %17s %s", $str, "x");
|
|
}
|
|
}
|
|
|
|
sub doComp
|
|
{
|
|
my ($fname, $head_str) = @_;
|
|
my ($key, $R, $r1, $r2, $diff, $rate, $flagX, $x, $i,
|
|
$retStr, $discrepancy, $err_diff_range, $err_zero_metric, $err_acct_mismatch);
|
|
|
|
sub setRate
|
|
{
|
|
my ($val, $diff) = @_;
|
|
return sprintf("%6.1f", ($diff/$val)*100) if ( $val != 0 );
|
|
return sprintf("%6.1f", "0.0") if ( $diff >= -0.05 && $diff <= 0.05);
|
|
return sprintf("%6.1f", "100") if ( $diff > 0 );
|
|
return sprintf("%6.1f", "-100");
|
|
}
|
|
|
|
$err_diff_range = 0;
|
|
$err_zero_metric = 0;
|
|
$err_acct_mismatch = 0;
|
|
$discrepancy = " ";
|
|
$flagX = " ";
|
|
$retStr = "";
|
|
for $i ( 0..$#Comparison ) {
|
|
$r1 = $Acct{$fname}[$Comparison[$i][1]];
|
|
$r2 = 0;
|
|
if ( ! exists $Rules{$fname} ) {
|
|
if ( exists $Erp->{$fname} ) {
|
|
$r2 = $Erp->{$fname}[$Comparison[$i][2]];
|
|
}
|
|
} else {
|
|
foreach my $key1 ( @{$Rules{$fname}} ) {
|
|
my $sign = 1;
|
|
$key = $key1;
|
|
if (substr($key1, 0, 1) eq '-') {
|
|
$key = substr($key1, 1);
|
|
$sign = -1;
|
|
}
|
|
if ( exists $Erp->{$key} ) {
|
|
$r2 += $sign * $Erp->{$key}[$Comparison[$i][2]];
|
|
}
|
|
}
|
|
}
|
|
|
|
$key = $Comparison[$i][0];
|
|
if( ! exists $RANGE{$key} ) {
|
|
printf "acct::doComp: '$key' is a wrong key\n\n";
|
|
exit $ERROR_PERL_ERROR;
|
|
}
|
|
$R = $RANGE{$key};
|
|
$r1 = sprintf($R->{FMT}, $r1);
|
|
$r2 = sprintf($R->{FMT}, $r2);
|
|
$diff = sprintf($R->{FMT}, $r1 - $r2);
|
|
$rate = &setRate($r1, $diff);
|
|
if ((( $diff > $R->{P_RANGE} ) && ( $rate >= $R->{P_RATE} ))
|
|
|| ( ( $fname ne '<Unknown>') && ( $diff < $R->{N_RANGE} ) && ( $rate <= $R->{N_RATE} ))) {
|
|
$x = ($Acct{$fname}[0] eq "Y") ? "y" : "x";
|
|
if ( $x ne "y" ) {
|
|
$flagX = "X";
|
|
&openDisFile();
|
|
printf Dis_fp "%s/ %s\n", $fname, $Comparison[$i][3];
|
|
|
|
$discrepancy .= " $Comparison[$i][3]";
|
|
if (with_diff($i)) {
|
|
if ( $r2 > 0 ) {
|
|
$err_diff_range = $ERROR_DIFF_RANGE;
|
|
} else {
|
|
$err_zero_metric = $ERROR_ZERO_METRIC;
|
|
}
|
|
} else {
|
|
$err_acct_mismatch = $ERROR_ACCT_MISMATCH;
|
|
}
|
|
}
|
|
} else {
|
|
$x = " ";
|
|
}
|
|
|
|
if (with_diff($i)) {
|
|
$retStr .= sprintf("| %8s %8s %7s %7s %s", $r1, $r2, $diff, $rate, $x);
|
|
} else {
|
|
$retStr .= sprintf("| %8s %8s %s", $r1, $r2, $x);
|
|
}
|
|
}
|
|
$retStr = $flagX . $retStr . sprintf(" %-10s", $fname);
|
|
if ( exists $Rules{$fname} ) {
|
|
$retStr .= sprintf " := %s", join(" + ", @{$Rules{$fname}});
|
|
}
|
|
if ($discrepancy ne " ") {
|
|
if ($err_acct_mismatch != 0) {
|
|
$retVal = $err_acct_mismatch;
|
|
}
|
|
&set_retVal($err_zero_metric);
|
|
&set_retVal($err_diff_range);
|
|
printf Scr1_fp "#%s\n#%s\n", $head_str, $retStr;
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'fsingle', $fname));
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'csingle', $fname));
|
|
}
|
|
return ($retStr);
|
|
}
|
|
|
|
sub doComp2AVG
|
|
{
|
|
my ($fname, $head_str, @avg) = @_;
|
|
my ($key, $R, $r1, $r2, $diff, $rate, $flagX, $x, $i,
|
|
$retStr, $discrepancy, $err_diff_range, $err_zero_metric, $err_acct_mismatch);
|
|
|
|
sub setRate
|
|
{
|
|
my ($val, $diff) = @_;
|
|
return sprintf("%6.1f", ($diff/$val)*100) if ( $val != 0 );
|
|
return sprintf("%6.1f", "0.0") if ( $diff >= -0.05 && $diff <= 0.05);
|
|
return sprintf("%6.1f", "100") if ( $diff > 0 );
|
|
return sprintf("%6.1f", "-100");
|
|
}
|
|
|
|
$err_diff_range = 0;
|
|
$err_zero_metric = 0;
|
|
$err_acct_mismatch = 0;
|
|
$discrepancy = " ";
|
|
$flagX = " ";
|
|
$retStr = "";
|
|
for $i ( 0..$#Comparison ) {
|
|
$r1 = $avg[$i];
|
|
$r2 = 0;
|
|
if ( ! exists $Rules{$fname} ) {
|
|
if ( exists $Erp->{$fname} ) {
|
|
$r2 = $Erp->{$fname}[$Comparison[$i][2]];
|
|
}
|
|
} else {
|
|
foreach my $key1 ( @{$Rules{$fname}} ) {
|
|
my $sign = 1;
|
|
$key = $key1;
|
|
if (substr($key1, 0, 1) eq '-') {
|
|
$key = substr($key1, 1);
|
|
$sign = -1;
|
|
}
|
|
if ( exists $Erp->{$key} ) {
|
|
$r2 += $sign * $Erp->{$key}[$Comparison[$i][2]];
|
|
}
|
|
}
|
|
}
|
|
|
|
$key = $Comparison[$i][0];
|
|
if( ! exists $RANGE{$key} ) {
|
|
printf "acct::doComp: '$key' is a wrong key\n\n";
|
|
exit $ERROR_PERL_ERROR;
|
|
}
|
|
$R = $RANGE{$key};
|
|
$r1 = sprintf($R->{FMT}, $r1);
|
|
$r2 = sprintf($R->{FMT}, $r2);
|
|
$diff = sprintf($R->{FMT}, $r1 - $r2);
|
|
$rate = &setRate($r1, $diff);
|
|
if ((( $diff > $R->{P_RANGE_2AVG} ) && ( $rate >= $R->{P_RATE_2AVG} ))
|
|
|| ( ( $fname ne '<Unknown>') && ( $diff < $R->{N_RANGE_2AVG} ) && ( $rate <= $R->{N_RATE_2AVG} ))) {
|
|
$flagX = "X";
|
|
$x = "x";
|
|
$discrepancy .= " $Comparison[$i][3]";
|
|
if (with_diff($i)) {
|
|
if ( $r2 > 0 ) {
|
|
$err_diff_range = $ERROR_DIFF_RANGE;
|
|
} else {
|
|
$err_zero_metric = $ERROR_ZERO_METRIC;
|
|
}
|
|
} else {
|
|
$err_acct_mismatch = $ERROR_ACCT_MISMATCH;
|
|
}
|
|
} else {
|
|
$x = " ";
|
|
}
|
|
|
|
if (with_diff($i)) {
|
|
$retStr .= sprintf("| %8s %8s %7s %7s %s", $r1, $r2, $diff, $rate, $x);
|
|
} else {
|
|
$retStr .= sprintf("| %8s %8s %s", $r1, $r2, $x);
|
|
}
|
|
}
|
|
$retStr = $flagX . $retStr . sprintf(" %-10s", $fname);
|
|
if ( exists $Rules{$fname} ) {
|
|
$retStr .= sprintf " := %s", join(" + ", @{$Rules{$fname}});
|
|
}
|
|
if ($discrepancy ne " ") {
|
|
if ($err_acct_mismatch != 0) {
|
|
$retVal = $err_acct_mismatch;
|
|
}
|
|
&set_retVal($err_zero_metric);
|
|
&set_retVal($err_diff_range);
|
|
&openDisFile();
|
|
printf Scr1_fp "#%s\n#%s\n", $head_str, $retStr;
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'fsingle', $fname));
|
|
printf Dis_fp "%s/%s\n", $fname, $discrepancy;
|
|
} else {
|
|
}
|
|
return ($retStr);
|
|
}
|
|
|
|
|
|
sub checkUnknown()
|
|
{
|
|
my ($total, $i, $R);
|
|
|
|
sub checkUnknRate()
|
|
{
|
|
my ($name, $N) = @_;
|
|
my ($val, $rate, $fmt);
|
|
|
|
$val = $Erp->{$name}[$Comparison[$N][2]];
|
|
$val = sprintf($R->{FMT}, $val);
|
|
$rate = sprintf($R->{FMT},($val / $total) * 100);
|
|
|
|
if (($val > $R->{'P_RANGE'}) && ($rate > $R->{'P_RATE'})) {
|
|
&set_retVal($ERROR_HIGH_UNKNOWN);
|
|
&openFsingleScr();
|
|
$fmt = "#%-8s %10s %10s %s\n";
|
|
printf Scr1_fp $fmt, $Comparison[$N][0], '%', '<Total>', $name;
|
|
printf Scr1_fp $fmt, ' ', $rate, $total, $val;
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'fsingle', '<Total>'));
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'csingle', '<Total>'));
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'fsingle', $name));
|
|
&commandToScr1_fp(sprintf("%s %s 1", 'csingle', $name));
|
|
&closeFsingleScr();
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
return if ( ! exists $Erp->{'<Total>'} );
|
|
return if ( $ENV{NOJAVA} );
|
|
$R = $RANGE{'Unkn'};
|
|
for $i ( 0..$#Comparison ) {
|
|
$total = $Erp->{'<Total>'}[$Comparison[$i][2]];
|
|
next if ( $total == 0 );
|
|
$total = sprintf($R->{FMT}, $total);
|
|
# last if &checkUnknRate('<Stack-unwind-failed>', $i);
|
|
last if &checkUnknRate('<Unknown>', $i);
|
|
last if &checkUnknRate('<no', $i);
|
|
}
|
|
}
|
|
|
|
sub createDiff
|
|
{
|
|
my ($key, $str, $i, $head_str);
|
|
|
|
&checkUnknown();
|
|
open(DIFF_fp, ">diff.out");
|
|
$head_str = " ";
|
|
for $i ( 0..$#Comparison ) {
|
|
printf DIFF_fp "Comparison[%d]: %s,%d,%d\n", $i,
|
|
$Comparison[$i][0], $Comparison[$i][1], $Comparison[$i][2], $Comparison[$i][3];
|
|
$head_str .= &get_head_str($i);
|
|
}
|
|
printf DIFF_fp "\nX| Compare the acct file (first column) with the er_print output (second column):\n";
|
|
$head_str .= " Name";
|
|
printf DIFF_fp "%s\n", $head_str;
|
|
foreach $key (sort keys %Acct) {
|
|
$str = &doComp($key, $head_str);
|
|
printf DIFF_fp "%s\n", $str;
|
|
}
|
|
&checkCallersCallees;
|
|
close(DIFF_fp);
|
|
&closeDisFile();
|
|
return -s "discrepancy.out"
|
|
}
|
|
|
|
sub createDiff2AVG
|
|
{
|
|
my ($key, $str, $i, $n, $head_str, @avg, $temp, $fname);
|
|
|
|
&checkUnknown();
|
|
open(DIFF_fp, ">>diff.out");
|
|
printf DIFF_fp "\n==================\n";
|
|
$head_str = " ";
|
|
for $i ( 0..$#Comparison ) {
|
|
printf DIFF_fp "Comparison[%d]: %s,%d\n", $i,
|
|
$Comparison[$i][0], $Comparison[$i][2];
|
|
$head_str .= &get_head_str($i);
|
|
}
|
|
printf DIFF_fp "\n#| Compare the avg value (first column) with the er_print output (second column):\n";
|
|
$head_str .= " Name";
|
|
printf DIFF_fp "%s\n", $head_str;
|
|
for $i ( 0..$#Comparison ) {
|
|
$avg[$i] = 0;
|
|
}
|
|
$n=0;
|
|
foreach $fname (sort keys %Acct) {
|
|
$n++;
|
|
for $i ( 0..$#Comparison ) {
|
|
if ( ! exists $Rules{$fname} ) {
|
|
if ( exists $Erp->{$fname} ) {
|
|
$temp = $Erp->{$fname}[$Comparison[$i][2]];
|
|
}
|
|
} else {
|
|
foreach my $key1 ( @{$Rules{$fname}} ) {
|
|
my $sign = 1;
|
|
$key = $key1;
|
|
if (substr($key1, 0, 1) eq '-') {
|
|
$key = substr($key1, 1);
|
|
$sign = -1;
|
|
}
|
|
if ( exists $Erp->{$key} ) {
|
|
$temp += $sign * $Erp->{$key}[$Comparison[$i][2]];
|
|
}
|
|
}
|
|
}
|
|
$avg[$i] += $temp;
|
|
}
|
|
}
|
|
for $i ( 0..$#Comparison ) {
|
|
$avg[$i] /= $n;
|
|
}
|
|
|
|
foreach $key (sort keys %Acct) {
|
|
$str = &doComp2AVG($key, $head_str, @avg);
|
|
printf DIFF_fp "%s\n", $str;
|
|
}
|
|
close(DIFF_fp);
|
|
&closeDisFile();
|
|
}
|
|
|
|
sub sumOutlinedCode
|
|
{ # Add a time of the outlined code.
|
|
my ($name, $eName);
|
|
foreach $name (keys %Acct) {
|
|
foreach $eName (keys %$Erp) {
|
|
next if ("$eName" !~ m/^($name)\s--/);
|
|
if (defined $Rules{$name}) {
|
|
push @{$Rules{$name}}, $eName;
|
|
} else {
|
|
$Rules{$name} = [$eName];
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
sub checkCallersCallees
|
|
{
|
|
my (@arr, $name, $colName, $line, $nline, %Calls);
|
|
|
|
open(FP, "<caller_callee.out") or return;
|
|
while ($line = <FP>) {
|
|
last if ( $line =~ m/\s+sec.\s+/ );
|
|
}
|
|
$nline = 0;
|
|
while ($line = <FP>) {
|
|
chomp($line);
|
|
$line =~ s/^\s*//; # Delete leading spaces
|
|
next if ( $line =~ m/^$/ );
|
|
@arr = split (/\s+/, $line, $colName);
|
|
$name = pop(@arr);
|
|
# New Callers-Callees format does not have * in the Stack Fragment section
|
|
# - translate old format to new format for compatibility
|
|
if ($name eq "*MAIN") { $name = "MAIN"; };
|
|
last if ($name eq "MAIN");
|
|
$nline += 1;
|
|
}
|
|
if ($nline == 0) {
|
|
printf "checkCallersCallees: No Callers of MAIN\n";
|
|
&set_retVal($ERROR_CALLER_VERIF);
|
|
close(FP);
|
|
return;
|
|
}
|
|
while ($line = <FP>) {
|
|
chomp($line);
|
|
$line =~ s/^\s*//; # Delete leading spaces
|
|
next if ( $line =~ m/^$/ );
|
|
@arr = split (/\s+/, $line, $colName);
|
|
$name = pop(@arr);
|
|
$Calls{$name} = 1;
|
|
if ( $line =~ /Parallel/ ) { #f90synprog M_EXPERT or M_MACHINE
|
|
@arr = split (/\s\s+/, $line, $colName);
|
|
$name = pop(@arr);
|
|
@arr = split (/\s/, $name);
|
|
$Calls{$arr[0]} = 1;
|
|
}
|
|
}
|
|
close(FP);
|
|
|
|
foreach $name (sort keys %Acct) {
|
|
next if ( $name eq '<Total>' ) ;
|
|
next if ( $name eq '<Unknown>' ) ;
|
|
next if (defined $Calls{$name}) ;
|
|
printf "checkCallersCallees: '$name' is not inside callees\n";
|
|
&set_retVal($ERROR_CALLER_VERIF);
|
|
}
|
|
}
|
|
|
|
|
|
return 1;
|
|
END{}
|
|
|