mirror of
https://sourceware.org/git/binutils-gdb.git
synced 2025-02-11 13:02:10 +08:00
76bdc7266a
This adds 'Innovative Computing Labs' as an external author to update-copyright.py, to cover the copyright notice in gprofng/common/opteron_pcbe.c, and uses that plus another external author 'Oracle and' to update gprofng copyright dates. I'm not going to commit 'Oracle and' as an accepted author, but that covers the string "Copyright (c) 2006, 2012, Oracle and/or its affiliates. All rights reserved." found in gprofng/testsuite/gprofng.display/jsynprog files.
775 lines
22 KiB
Perl
775 lines
22 KiB
Perl
# Copyright (C) 2021-2023 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{}
|
|
|