# along with this program; if not, write to the Free Software
# Foundation, 51 Franklin Street - Fifth Floor, Boston,
# MA 02110-1301, USA.
-
+
use strict;
use warnings;
-use feature qw (state);
+
+# Disable before release
+# use Perl::Critic;
+
+use bignum;
+use List::Util qw (max);
+use Cwd qw (abs_path cwd);
+use File::Basename;
use File::stat;
+use feature qw (state);
+use POSIX;
+use Getopt::Long qw (Configure);
#------------------------------------------------------------------------------
# Check as early as possible if the version of Perl used is supported.
#------------------------------------------------------------------------------
my $g_path_to_tools;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Code debugging flag
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $g_test_code = $FALSE;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# GPROFNG commands and files used.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $GP_DISPLAY_TEXT = "gp-display-text";
my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log";
my $g_html_less_than_regex = '<';
my $g_endbr_inst_regex = 'endbr[32|64]';
+#------------------------------------------------------------------------------
+# For consistency, use a global variable.
+#------------------------------------------------------------------------------
+ my $g_html_new_line = "<br>";
+
#------------------------------------------------------------------------------
# These are the regex's used.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
- my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
-
-#------------------------------------------------------------------------------
-# Convenience. These map the on/off value to $TRUE/$FALSE to make the code
-# easier to read. For example: "if ($g_verbose)" as opposed to the following:
-# "if ($verbose_setting eq "on").
-#------------------------------------------------------------------------------
-my $g_verbose;
-my $g_warnings;
-my $g_quiet;
+ my $g_function_call_v2_regex =
+ '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
-my $g_first_metric;
+my $g_first_metric;
my $binutils_version;
my $driver_cmd;
my %g_mapped_cmds = ();
#------------------------------------------------------------------------------
-# TBD All warning messages are collected and are accessible through the main
-# page.
+# Variables dealing with warnings and errors. Since a message may span
+# multiple lines (for readability reasons), the number of entries in the
+# array may not reflect the total number of messages. This is why we use
+# separate variables for the counts.
+#------------------------------------------------------------------------------
+my @g_error_msgs = ();
+my @g_warning_msgs = ();
+my $g_total_error_count = 0;
#------------------------------------------------------------------------------
-my @g_warning_messages = ();
+# This count is used in the html_create_warnings_page HTML page to show how
+# many warning messages there are. Warnings are printed through gp_message(),
+# but since one warning may span multiple lines, we update a separate counter
+# that contains the total number of warning messages issued so far.
+#------------------------------------------------------------------------------
+my $g_total_warning_count = 0;
+my $g_options_printed = $FALSE;
+my $g_abort_msg = "cannot recover from the error(s)";
#------------------------------------------------------------------------------
# Contains the names that have already been tagged. This is a global
my $g_default_setting_lang = "en-US.UTF-8";
my %g_exp_dir_meta_data;
-my @g_user_input_errors = ();
-
my $g_html_credits_line;
-my $g_warn_keyword = "Input warning: ";
-my $g_error_keyword = "Input error: ";
+my $g_warn_keyword = "[Warning]";
+my $g_error_keyword = "[Error]";
my %g_function_occurrences = ();
my %g_map_function_to_index = ();
my @g_html_experiment_stats = ();
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# These structures contain the information printed in the function views.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $g_header_lines;
my @g_html_function_name = ();
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD: This variable may not be needed and replaced by tp_value
my $thresh = 0;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Define the driver command, tool name and version number.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$driver_cmd = "gprofng display html";
$tool_name = "gp-display-html";
#$binutils_version = "2.38.50";
$binutils_version = "BINUTILS_VERSION";
$version_info = $tool_name . " GNU binutils version " . $binutils_version;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Define several key data structures.
-#-------------------------------------------------------------------------------
-my %g_user_settings =
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# This table has the settings of the variables the user may set.
+#------------------------------------------------------------------------------
+my %g_user_settings =
(
- output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
- overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
- calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
- func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE},
- highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE},
- threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE},
- default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
- ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE},
- verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
- warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE},
- debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE},
- quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
+ verbose => { option => "--verbose",
+ no_of_arguments => 1,
+ data_type => "onoff",
+ current_value => "off", defined => $FALSE},
+
+ debug => { option => "--debug",
+ no_of_arguments => 1,
+ data_type => "size",
+ current_value => "off", defined => $FALSE},
+
+ warnings => { option => "--warnings",
+ no_of_arguments => 1,
+ data_type => "onoff" ,
+ current_value => "off", defined => $FALSE},
+
+ nowarnings => { option => "--nowarnings",
+ no_of_arguments => 1,
+ data_type => "onoff",
+ current_value => "off", defined => $FALSE},
+
+ quiet => { option => "--quiet",
+ no_of_arguments => 1,
+ data_type => "onoff",
+ current_value => "off", defined => $FALSE},
+
+ output => { option => "-o",
+ no_of_arguments => 1,
+ data_type => "path",
+ current_value => undef, defined => $FALSE},
+
+ overwrite => { option => "-O",
+ no_of_arguments => 1,
+ data_type => "path",
+ current_value => undef, defined => $FALSE},
+
+ calltree => { option => "-ct",
+ no_of_arguments => 1,
+ data_type => "onoff",
+ current_value => "off", defined => $FALSE},
+
+ func_limit => { option => "-fl",
+ no_of_arguments => 1,
+ data_type => "pinteger",
+ current_value => 500, defined => $FALSE},
+
+ highlight_percentage => { option => "--highlight-percentage",
+ no_of_arguments => 1,
+ data_type => "pfloat",
+ current_value => 90.0, defined => $FALSE},
+
+ hp => { option => "-hp",
+ no_of_arguments => 1,
+ data_type => "pfloat",
+ current_value => 90.0, defined => $FALSE},
+
+ threshold_percentage => { option => "-tp",
+ no_of_arguments => 1,
+ data_type => "pfloat",
+ current_value => 100.0, defined => $FALSE},
+
+ default_metrics => { option => "-dm",
+ no_of_arguments => 1,
+ data_type => "onoff",
+ current_value => "off", defined => $FALSE},
+
+ ignore_metrics => { option => "-im",
+ no_of_arguments => 1,
+ data_type => "metric_names",
+ current_value => undef, defined => $FALSE},
);
-my %g_debug_size =
+#------------------------------------------------------------------------------
+# Convenience. These map the on/off value to $TRUE/$FALSE to make the code
+# easier to read. For example: "if ($g_verbose)" as opposed to the following:
+# "if ($verbose_setting eq "on").
+#------------------------------------------------------------------------------
+my $g_verbose = $FALSE;
+my $g_debug = $FALSE;
+my $g_warnings = $TRUE;
+my $g_quiet = $FALSE;
+
+#------------------------------------------------------------------------------
+# Since ARGV is modified when parsing the options, a clean copy is used to
+# print the original ARGV values in case of a warning, or error.
+#------------------------------------------------------------------------------
+my @CopyOfARGV = ();
+
+my %g_debug_size =
(
"on" => $FALSE,
"s" => $FALSE,
hostname_current => "undefined",
);
-# Note that we use single quotes here, because regular expressions wreak havoc otherwise.
+#------------------------------------------------------------------------------
+# Note that we use single quotes here, because regular expressions wreak
+# havoc otherwise.
+#------------------------------------------------------------------------------
my %g_arch_specific_settings =
(
);
#------------------------------------------------------------------------------
-# This is cosmetic, but helps with the scoping of variables.
+# Introducing main() is cosmetic, but helps with the scoping of variables.
#------------------------------------------------------------------------------
main ();
{
my $subr_name = get_my_name ();
+ @CopyOfARGV = @ARGV;
+
#------------------------------------------------------------------------------
# The name of the configuration file.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# OS commands executed and search paths.
+#
+# TBD: check if elfdump should be here too (most likely not though)
#------------------------------------------------------------------------------
- my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls
- uname readelf mkdir);
+ my @selected_os_cmds = qw (rm cat hostname locale which printenv uname
+ readelf mkdir);
+
my @search_paths_os_cmds = qw (
/usr/bin
/bin
#------------------------------------------------------------------------------
# Local structures (hashes and arrays).
#------------------------------------------------------------------------------
- my @exp_dir_list; # List with experiment directories
+ my @exp_dir_list = ();
my @metrics_data;
my %function_address_info = ();
- my $function_address_info_ref;
+ my $function_address_info_ref;
my @function_info = ();
my $function_info_ref;
#------------------------------------------------------------------------------
# Local variables.
#------------------------------------------------------------------------------
- my $abs_path_outputdir;
+ my $abs_path_outputdir;
my $archive_dir_not_empty;
- my $base_va_executable;
+ my $base_va_executable;
my $executable_name;
- my $exp_dir_list_ref;
my $found_exp_dir;
my $ignore_value;
- my $message;
+ my $msg;
my $number_of_metrics;
my $va_executable_in_hex;
- my $failed_command_mappings;
- my $option_errors;
- my $total_user_errors;
+ my $failed_command_mappings;
- my $script_pc_metrics;
+ my $script_pc_metrics;
my $dir_check_errors;
my $consistency_errors;
my $outputdir;
my $elf_arch;
my $elf_support;
my $home_dir;
- my $elf_loadobjects_found;
+ my $elf_loadobjects_found;
my $rc_file_paths_ref;
my @rc_file_paths = ();
my $system_metrics;
my $wall_metrics;
my $detail_metrics;
- my $detail_metrics_system;
+ my $detail_metrics_system;
+
+ my $html_test;
+ my @experiment_data;
+ my $exp_info_file;
+ my $exp_info_ref;
+ my @exp_info;
- my $pretty_dir_list;
+ my $pretty_dir_list;
my %metric_value = ();
my %metric_description = ();
#------------------------------------------------------------------------------
if ($#ARGV == -1)
{
- $ignore_value = print_help_info ();
+ $ignore_value = print_help_info ();
return (0);
}
#------------------------------------------------------------------------------
-# This part is like a preamble. Before we continue we need to figure out some
+# This part is like a preamble. Before we continue we need to figure out some
# things that are needed later on.
#------------------------------------------------------------------------------
my $location_gp_command = $0;
#------------------------------------------------------------------------------
-# The very first thing to do is to quickly determine if the user has enabled
-# one of the following options and take action accordingly:
-# --version, --verbose, --debug, --quiet
+# Get the ball rolling. Parse and interpret the options. Some first checks
+# are performed.
#
-# This avoids that there is a gap between the start of the execution and the
-# moment the options are parsed, checked, and interpreted.
+# Instead of bailing out on the first user error, we capture all warnings and
+# errors. The warnings, if any, will be printed once the command line has
+# been parsed and verified. Execution continues.
#
-# When parsing the full command line, these options will be more extensively
-# checked and also updated in %g_user_settings
-
-# Note that a confirmation message, if any, is printed here and not when the
-# options are parsed and processed.
-#------------------------------------------------------------------------------
-
- $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
-
- $ignore_value = early_scan_specific_options ();
-
-#------------------------------------------------------------------------------
-# The next subroutine is executed early to ensure the OS commands we need are
-# available.
+# Any error(s) accumulated in this phase will be printed after the command
+# line has been parsed and verified. Execution is then terminated.
#
-# This subroutine stores the commands and the full path names as an associative
-# array called "g_mapped_cmds". The command is the key and the value is the full
-# path. For example: ("uname", /usr/bin/uname).
+# In the remainder, any error encountered will immediately terminate the
+# execution because we can't guarantee the remaining code will work up to
+# some point.
#------------------------------------------------------------------------------
- $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds);
+ my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options ();
- if ($failed_command_mappings == 0)
+ $found_exp_dir = ${ $found_exp_dir_ref };
+
+ if ($found_exp_dir)
{
- gp_message ("debug", $subr_name, "verified the OS commands");
+ @exp_dir_list = @{ $exp_dir_list_ref };
}
else
{
- my $msg = "failure in the verification of the OS commands";
- gp_message ("assertion", $subr_name, $msg);
+ $msg = "the list with experiments is either missing, or incorrect";
+ gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# Get the home directory and the locations for the configuration file on the
-# current system.
-#------------------------------------------------------------------------------
- ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name);
-
- @rc_file_paths = @{ $rc_file_paths_ref };
- gp_message ("debug", $subr_name, "the home directory is $home_dir");
- gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths");
-
- $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths);
-
-#------------------------------------------------------------------------------
-# Get the ball rolling. Parse and interpret the configuration file (if any)
-# and the command line options.
-#
-# If either $rc_file_errors or $total_user_errors, or both, are non-zero it
-# means a fatal error has occured. In this case, all error messages are
-# printed and execution is terminated.
-#
-# Note that the verbose, debug, and quiet options can be set in this file.
-# It is a deliberate choice to ignore these for now. The assumption is that
-# the user will not be happy if we ignore the command line settings for a
-# while.
+# The final settings for verbose, debug, warnings and quiet are known and the
+# gp_message() subroutine is aware of these.
#------------------------------------------------------------------------------
-
- gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now");
-
-# Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file");
-# Temporarily disabled
-# Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref);
-# Temporarily disabled
-# Temporarily disabled if ($rc_file_errors != 0)
-# Temporarily disabled {
-# Temporarily disabled $message = "fatal errors in file $rc_file_name encountered";
-# Temporarily disabled gp_message ("debugXL", $subr_name, $message);
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file");
+ $msg = "parsing of the user options completed";
+ gp_message ("verbose", $subr_name, $msg);
#------------------------------------------------------------------------------
-# Get the ball rolling. Parse and interpret the options. Some first checks
-# are performed.
-#
-# Instead of bailing out on the first user error, we capture all errors, print
-# messages and then bail out. This is more user friendly.
+# The user options have been taken in. Check for validity and consistency.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Parse the user options");
+ $msg = "process user options";
+ gp_message ("verbose", $subr_name, $msg);
- $total_user_errors = 0;
+ ($ignored_metrics_ref, $outputdir,
+ $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) =
+ process_user_options (\@exp_dir_list);
- ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options (
- \$#ARGV,
- \@ARGV);
- $total_user_errors += $option_errors;
+ @exp_dir_list = @{ $exp_dir_list_ref };
+ %ignored_metrics = %{$ignored_metrics_ref};
#------------------------------------------------------------------------------
-# Dynamically load the modules needed. If a module is not available, print
-# an error message and bail out.
-#
-# This call replaces the following:
-#
-# use feature qw (state);
-# use List::Util qw (min max);
-# use Cwd;
-# use File::Basename;
-# use File::stat;
-# use POSIX;
-# use bignum;
+# The next subroutine is executed early to ensure the OS commands we need are
+# available.
#
-# Note that this check cannot be done earlier, because in case of a missing
-# module, the man page would not be generated if the code ends prematurely
-# in case the --help and --version options are used..
+# This subroutine stores the commands and the full path names as an
+# associative array called "g_mapped_cmds". The command is the key and the
+# value is the full path. For example: ("uname", /usr/bin/uname).
#------------------------------------------------------------------------------
- my ($module_errors_ref, $missing_modules_ref) = handle_module_availability ();
-
- my $module_errors = ${ $module_errors_ref };
+ gp_message ("debug", $subr_name, "verify the OS commands");
+ $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds,
+ \@search_paths_os_cmds);
- if ($module_errors > 0)
+ if ($failed_command_mappings == 0)
{
- my $msg;
-
- my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is";
- my @missing_modules = @{ $missing_modules_ref };
-
- for my $i (0 .. $#missing_modules)
- {
- $msg = "module $missing_modules[$i] is missing";
- gp_message ("error", $subr_name, $msg);
- }
-
- $msg = $module_errors . " " . $plural_or_single .
- "missing - execution is terminated";
- gp_message ("abort", $subr_name, $msg);
+ $msg = "successfully verified the OS commands";
+ gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# The user options have been taken in. Check for validity and consistency.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Process user options");
-
- ($option_errors, $ignored_metrics_ref, $outputdir,
- $time_percentage_multiplier, $process_all_functions,
- $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref);
-
- @exp_dir_list = @{ $exp_dir_list_ref };
- %ignored_metrics = %{$ignored_metrics_ref};
-
- $total_user_errors += $option_errors;
-
+# Time to check if any warnings and/or errors have been generated.
#------------------------------------------------------------------------------
-# If no option is given for the output directory, pick a default. Otherwise,
-# if the output directory exists, wipe it clean in case the -O option is used.
-# If not, flag an error because the -o option does not overwrite an existing
-# directory.
#------------------------------------------------------------------------------
- if ($total_user_errors == 0)
- {
- ($option_errors, $outputdir) = set_up_output_directory ();
- $abs_path_outputdir = cwd () . "/" . $outputdir;
- $total_user_errors += $option_errors;
- }
- if ($total_user_errors == 0)
- {
- gp_message ("debug", $subr_name, "the output directory is $outputdir");
- }
- else
- {
#------------------------------------------------------------------------------
-# All command line errors and warnings are printed here.
+# We have completed all the upfront checks. Print any warnings and errors.
+# If there are already any errors, execution is terminated. As execution
+# continues, errors may occur and they are typically fatal.
#------------------------------------------------------------------------------
- my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has";
- $message = $g_error_keyword;
- $message .= $total_user_errors;
- if ($rc_file_errors > 0)
- {
- $message .= " additional";
- }
- $message .= " fatal input $plural_or_single been detected:";
- gp_message ("error", $subr_name, $message);
- for my $key (keys @g_user_input_errors)
- {
- gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]");
- }
+ if ($g_debug)
+ {
+ $msg = "internal settings after option processing";
+ $ignore_value = print_table_user_settings ("diag", $msg);
}
#------------------------------------------------------------------------------
-# Bail out in case fatal errors have occurred.
+# Terminate execution in case fatal errors have occurred.
#------------------------------------------------------------------------------
- if ( ($rc_file_errors + $total_user_errors) > 0)
+ if ( $g_total_error_count > 0)
{
my $msg = "the current values for the user controllable settings";
print_user_settings ("debug", $msg);
- gp_message ("abort", $subr_name, "execution terminated");
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
else
{
my $msg = "after parsing the user options, the final values are";
print_user_settings ("debug", $msg);
+ }
+
+#------------------------------------------------------------------------------
+# If no option is given for the output directory, pick a default. Otherwise,
+# if the output directory exists, wipe it clean in case the -O option is used.
+# If not, raise an error because the -o option does not overwrite an existing
+# directory.
+# Also in case of other errors, the execution is terminated.
+#------------------------------------------------------------------------------
+ $outputdir = set_up_output_directory ();
+ $abs_path_outputdir = Cwd::cwd () . "/" . $outputdir;
+
+ $msg = "the output directory is $outputdir";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
-# TBD: Enable once all planned features have been implemented and tested.
+# Get the home directory and the locations for the configuration file on the
+# current system.
#------------------------------------------------------------------------------
-# Temporarily disabled $msg = "the final values for the user controllable settings";
-# Temporarily disabled print_table_user_settings ("verbose", $msg);
- }
+ ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name);
+
+ @rc_file_paths = @{ $rc_file_paths_ref };
+
+ $msg = "the home directory is $home_dir";
+ gp_message ("debug", $subr_name, $msg);
+
+#------------------------------------------------------------------------------
+# TBD: de-activated until this feature has been fully implemented.
+#------------------------------------------------------------------------------
+## $msg = "the search path for the rc file is @rc_file_paths";
+## gp_message ("debug", $subr_name, $msg);
+## $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths);
+
+#------------------------------------------------------------------------------
+# Get the ball rolling. Parse and interpret the configuration file (if any)
+# and the command line options.
+#
+# Note that the verbose, debug, and quiet options can be set in this file.
+# It is a deliberate choice to ignore these for now. The assumption is that
+# the user will not be happy if we ignore the command line settings for a
+# while.
+#------------------------------------------------------------------------------
+ $msg = "processing of the rc file has been disabled for now";
+ gp_message ("debugXL", $subr_name, $msg);
+
+# Temporarily disabled
+# print_table_user_settings ("debugXL", "before function process_rc_file");
+# $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref);
+# if ($rc_file_errors != 0)
+# {
+# $message = "fatal errors in file $rc_file_name encountered";
+# gp_message ("debugXL", $subr_name, $message);
+# }
+# print_table_user_settings ("debugXL", "after function process_rc_file");
#------------------------------------------------------------------------------
# Print a list with the experiment directory names
my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is";
- gp_message ("verbose", $subr_name, "The experiment " . $plural . ":");
+ $msg = "the experiment " . $plural . ":";
+ gp_message ("verbose", $subr_name, $msg);
gp_message ("verbose", $subr_name, $pretty_dir_list);
#------------------------------------------------------------------------------
for my $exp_dir (@exp_dir_list)
{
my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir);
- gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
- gp_message ("debug", $subr_name, "filename = $filename");
- gp_message ("debug", $subr_name, "directory_path = $directory_path");
- $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path;
+ gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
+ gp_message ("debug", $subr_name, "filename = $filename");
+ gp_message ("debug", $subr_name, "directory_path = $directory_path");
+ $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path;
}
#------------------------------------------------------------------------------
-# Check whether the experiment directories are valid. If not, it is a fatal
-# error.
-# Upon successful return, one directory has been selected to be used in the
-# remainder. This is not always the correct thing to do, but is the same as
-# the original code. In due time this should be addressed though.
+# TBD:
+# This subroutine may be overkill. See what is really needed here and remove
+# everything else.
+#
+# Upon return, one directory has been selected to be used in the remainder.
+# This is not always the correct thing to do, but is the same as the original
+# code. In due time this should be addressed though.
#------------------------------------------------------------------------------
- ($dir_check_errors, $archive_dir_not_empty, $selected_archive,
- $elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref);
-
- if ($dir_check_errors)
- {
- gp_message ("abort", $subr_name, "execution terminated");
- }
- else
- {
- gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid");
- }
+ ($archive_dir_not_empty, $selected_archive, $elf_rats_ref) =
+ check_validity_exp_dirs (\@exp_dir_list);
%elf_rats = %{$elf_rats_ref};
-#-------------------------------------------------------------------------------
+ $msg = "the experiment directories have been verified and are valid";
+ gp_message ("verbose", $subr_name, $msg);
+
+#------------------------------------------------------------------------------
# Now that we know the map.xml file(s) are present, we can scan these and get
# the required information. This includes setting the base virtual address.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$ignore_value = determine_base_virtual_address ($exp_dir_list_ref);
#------------------------------------------------------------------------------
# Check whether the experiment directories are consistent.
#------------------------------------------------------------------------------
- ($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref);
+ ($consistency_errors, $executable_name) =
+ verify_consistency_experiments ($exp_dir_list_ref);
if ($consistency_errors == 0)
{
- gp_message ("verbose", $subr_name, "The experiment directories are consistent");
+ $msg = "the experiment directories are consistent";
+ gp_message ("verbose", $subr_name, $msg);
}
else
{
- gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors");
+ $msg = "the number of consistency errors detected: $consistency_errors";
+ gp_message ("abort", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# The directories are consistent. We can now set the base virtual address of
# the executable.
#------------------------------------------------------------------------------
- $base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"};
+ $base_va_executable =
+ $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"};
- gp_message ("debug", $subr_name, "executable_name = $executable_name");
- gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
- gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable");
+ $msg = "executable_name = " . $executable_name;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "selected_archive = " . $selected_archive;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "base_va_executable = " . $base_va_executable;
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
-# The $GP_DISPLAY_TEXT tool is critical and has to be available in order
-# to proceed.
-# This subroutine only returns a value if the tool can be found."
+# The $GP_DISPLAY_TEXT tool is critical and has to be available in order to
+# proceed.
+# This subroutine only returns a value if the tool can be found.
#------------------------------------------------------------------------------
$g_path_to_tools = ${ check_availability_tool (\$location_gp_command)};
$GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT;
- gp_message ("debug", $subr_name, "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT");
+ $msg = "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Check if $GP_DISPLAY_TEXT is executable for user, group, and other.
#------------------------------------------------------------------------------
if (not is_file_executable ($GP_DISPLAY_TEXT))
{
- my $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and other";
+ $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and";
+ $msg .= " other";
gp_message ("warning", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Find out what the decimal separator is, as set by the user.
#------------------------------------------------------------------------------
- ($return_code, $decimal_separator, $convert_to_dot) =
+ ($return_code, $decimal_separator, $convert_to_dot) =
determine_decimal_separator ();
if ($return_code == 0)
{
- my $txt = "decimal separator is $decimal_separator " .
- "(conversion to dot is " .
- ($convert_to_dot == $TRUE ? "enabled" : "disabled").")";
- gp_message ("debugXL", $subr_name, $txt);
+ $msg = "decimal separator is $decimal_separator";
+ $msg .= " (conversion to dot is ";
+ $msg .= ($convert_to_dot == $TRUE ? "enabled" : "disabled") . ")";
+ gp_message ("debugXL", $subr_name, $msg);
}
else
{
- my $msg = "the decimal separator cannot be determined - set to $decimal_separator";
+ $msg = "the decimal separator cannot be determined -";
+ $msg .= " set to $decimal_separator";
gp_message ("warning", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Collect and store the system information.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Collect system information and adapt settings");
+ $msg = "collect system information and adapt settings";
+ gp_message ("verbose", $subr_name, $msg);
- $return_code = get_system_config_info ();
+ $return_code = get_system_config_info ();
#------------------------------------------------------------------------------
# The 3 variables below are used in the remainder.
gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s");
gp_message ("debug", $subr_name, "set arch_uname = $arch_uname");
-#-------------------------------------------------------------------------------
-# This function also sets the values in "g_arch_specific_settings". This
+#------------------------------------------------------------------------------
+# This function also sets the values in "g_arch_specific_settings". This
# includes several definitions of regular expressions.
-#-------------------------------------------------------------------------------
- ($architecture_supported, $elf_arch, $elf_support) =
- set_system_specific_variables ($arch_uname, $arch_uname_s);
+#------------------------------------------------------------------------------
+ ($architecture_supported, $elf_arch, $elf_support) =
+ set_system_specific_variables ($arch_uname, $arch_uname_s);
- gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported");
- gp_message ("debug", $subr_name, "elf_arch = $elf_arch");
- gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE"));
+ $msg = "architecture_supported = $architecture_supported";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "elf_arch = $elf_arch";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "elf_support = ".($elf_arch ? "TRUE" : "FALSE");
+ gp_message ("debug", $subr_name, $msg);
for my $feature (sort keys %g_arch_specific_settings)
{
- gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}");
+ $msg = "g_arch_specific_settings{$feature} = ";
+ $msg .= $g_arch_specific_settings{$feature};
+ gp_message ("debug", $subr_name, $msg);
}
$arch = $g_arch_specific_settings{"arch"};
$g_locale_settings{"LANG"} = get_LANG_setting ();
- gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}");
+ $msg = "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}";
+ gp_message ("debugXL", $subr_name, $msg);
#------------------------------------------------------------------------------
# Temporarily reset selected settings since these are not yet implemented.
# TBD: Revisit. Is this really necessary?
#------------------------------------------------------------------------------
- ($executable_name, $va_executable_in_hex) = check_loadobjects_are_elf ($selected_archive);
+ ($executable_name, $va_executable_in_hex) =
+ check_loadobjects_are_elf ($selected_archive);
$elf_loadobjects_found = $TRUE;
# TBD: Hack and those ARCHIVES_ names can be eliminated
$ARCHIVES_MAP_NAME = $executable_name;
$ARCHIVES_MAP_VADDR = $va_executable_in_hex;
- gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
- gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
- gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found");
-
+ $msg = "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME";
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ $msg = "after call to check_loadobjects_are_elf forced";
+ $msg .= " elf_loadobjects_found = $elf_loadobjects_found";
+ gp_message ("debugXL", $subr_name, $msg);
+
$g_html_credits_line = ${ create_html_credits () };
- gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line");
+
+ $msg = "g_html_credits_line = $g_html_credits_line";
+ gp_message ("debugXL", $subr_name, $msg);
+
#------------------------------------------------------------------------------
# Add a "/" to simplify the construction of path names in the remainder.
#
$detail_metrics_system = 'e.totalcpu:e.system';
$call_metrics = 'a.totalcpu';
- my $cmd_options;
+ my $cmd_options;
my $metrics_cmd;
my $outfile1 = $outputdir ."metrics";
# to get all the output in files $outfile1 and $outfile2. These are then
# parsed.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments");
+ $msg = "gather the metrics data from the experiments";
+ gp_message ("verbose", $subr_name, $msg);
- $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file);
+ $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1,
+ $outfile2, $gp_error_file);
if ($return_code != 0)
{
#------------------------------------------------------------------------------
# TBD: Test this code
#------------------------------------------------------------------------------
- open (METRICS, "<", $outfile1)
- or die ("$subr_name - unable to open metric value data file $outfile1 for reading: '$!'");
+ $msg = "unable to open metric value data file $outfile1 for reading:";
+ open (METRICS, "<", $outfile1)
+ or die ($subr_name . " - " . $msg . " " . $!);
+
+ $msg = "opened file $outfile1 for reading";
gp_message ("debug", $subr_name, "opened file $outfile1 for reading");
chomp (@metrics_data = <METRICS>);
for my $i (keys @metrics_data)
{
- gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]");
+ $msg = "metrics_data[$i] = " . $metrics_data[$i];
+ gp_message ("debugXL", $subr_name, $msg);
}
#------------------------------------------------------------------------------
{
gp_message ("verbose", $subr_name, "Process the metrics data");
- ($metric_value_ref, $metric_description_ref, $metric_found_ref,
+ ($metric_value_ref, $metric_description_ref, $metric_found_ref,
$user_metrics, $system_metrics, $wall_metrics,
$summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics
) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics);
%metric_found = %{ $metric_found_ref };
%metric_description_reversed = reverse %metric_description;
- gp_message ("debugXL", $subr_name, "after the call to process_metrics_data");
+ $msg = "after the call to process_metrics_data";
+ gp_message ("debugXL", $subr_name, $msg);
+
for my $metric (sort keys %metric_value)
{
- gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}");
+ $msg = "metric_value{$metric} = " . $metric_value{$metric};
+ gp_message ("debugXL", $subr_name, $msg);
}
for my $metric (sort keys %metric_description)
{
- gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}");
+ $msg = "metric_description{$metric} =";
+ $msg .= " " . $metric_description{$metric};
+ gp_message ("debugXL", $subr_name, $msg);
}
gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics");
gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics");
#
# TBD: These should be OS dependent.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Select the set of default metrics");
+ $msg = "select the set of default metrics";
+ gp_message ("verbose", $subr_name, $msg);
- ($metric_description_ref, $metric_found_ref, $summary_metrics,
+ ($metric_description_ref, $metric_found_ref, $summary_metrics,
$detail_metrics, $detail_metrics_system, $call_metrics
) = set_default_metrics ($outfile1, \%ignored_metrics);
%metric_found = %{ $metric_found_ref };
%metric_description_reversed = reverse %metric_description;
- gp_message ("debug", $subr_name, "after the call to set_default_metrics");
+ $msg = "after the call to set_default_metrics";
+ gp_message ("debug", $subr_name, $msg);
}
$number_of_metrics = split (":", $summary_metrics);
- gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics");
- gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics");
- gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system");
- gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics");
- gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics");
+ $msg = "summary_metrics = " . $summary_metrics;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "detail_metrics = " . $detail_metrics;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "detail_metrics_system = " . $detail_metrics_system;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "call_metrics = " . $call_metrics;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "number_of_metrics = " . $number_of_metrics;
+ gp_message ("debugXL", $subr_name, $msg);
#------------------------------------------------------------------------------
# TBD Find a way to better handle this situation:
#------------------------------------------------------------------------------
for my $im (keys %metric_found)
{
- gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}");
+ $msg = "metric_found{$im} = " . $metric_found{$im};
+ gp_message ("debugXL", $subr_name, $msg);
}
for my $im (keys %ignored_metrics)
{
if (not exists ($metric_found{$im}))
{
- gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics");
+ $msg = "user requested ignored metric (-im) $im does not exist in";
+ $msg .= " collected metrics";
+ gp_message ("debugXL", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
# Get the information on the experiments.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Generate the experiment information");
-
- my $exp_info_file_ref;
- my $exp_info_file;
- my $exp_info_ref;
- my @exp_info;
-
- my $experiment_data_ref;
+ $msg = "generate the experiment information";
+ gp_message ("verbose", $subr_name, $msg);
- $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list);
- my @experiment_data = @{ $experiment_data_ref };
+ my $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list);
+ @experiment_data = @{ $experiment_data_ref };
for my $i (sort keys @experiment_data)
{
- my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " .
+ my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " .
$experiment_data[$i]{"exp_name_full"};
gp_message ("debugM", $subr_name, $msg);
}
}
}
- @g_html_experiment_stats = @{ create_exp_info (
- \@exp_dir_list,
- \@experiment_data) };
+ @g_html_experiment_stats = @{ create_exp_info (\@exp_dir_list,
+ \@experiment_data) };
- $table_execution_stats_ref = html_generate_exp_summary (
- \$outputdir,
- \@experiment_data);
+ $table_execution_stats_ref = html_generate_exp_summary (\$outputdir,
+ \@experiment_data);
@table_execution_stats = @{ $table_execution_stats_ref };
#------------------------------------------------------------------------------
# Get the function overview.
#------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Generate the list with functions executed");
+ $msg = "generate the list with functions executed";
+ gp_message ("verbose", $subr_name, $msg);
- my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir);
+ my ($outfile, $sort_fields_ref) =
+ get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir);
@sort_fields = @{$sort_fields_ref};
# Parse the output from the fsummary command and store the relevant data for
# all the functions listed there.
#------------------------------------------------------------------------------
+ $msg = "analyze and store the relevant function information";
+ gp_message ("verbose", $subr_name, $msg);
- gp_message ("verbose", $subr_name, "Analyze and store the relevant function information");
-
- ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref,
- $LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile);
+ ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref,
+ $LINUX_vDSO_ref, $function_view_structure_ref) =
+ get_function_info ($outfile);
@function_info = @{ $function_info_ref };
%function_address_and_index = %{ $function_address_and_index_ref };
{
for my $fields (keys %{$function_info[$keys]})
{
- gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}");
+ $msg = "$keys $fields $function_info[$keys]{$fields}";
+ gp_message ("debugXL", $subr_name, $msg);
}
}
for my $i (keys %addressobjtextm)
{
- gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}");
+ $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i};
+ gp_message ("debugXL", $subr_name, $msg);
}
- gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information");
+ $msg = "generate the files with function overviews and the";
+ $msg .= " callers-callees information";
+ gp_message ("verbose", $subr_name, $msg);
- $script_pc_metrics = generate_function_level_info (\@exp_dir_list,
- $call_metrics,
- $summary_metrics,
- $outputdir,
+ $script_pc_metrics = generate_function_level_info (\@exp_dir_list,
+ $call_metrics,
+ $summary_metrics,
+ $outputdir,
$sort_fields_ref);
- gp_message ("verbose", $subr_name, "Preprocess the files with the function level information");
+ $msg = "preprocess the files with the function level information";
+ gp_message ("verbose", $subr_name, $msg);
$ignore_value = preprocess_function_files (
- $metric_description_ref,
- $script_pc_metrics,
- $outputdir,
+ $metric_description_ref,
+ $script_pc_metrics,
+ $outputdir,
\@sort_fields);
- gp_message ("verbose", $subr_name, "For each function, generate a set of files");
-
- ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files (
- \@exp_dir_list,
- $executable_name,
- $time_percentage_multiplier,
- $summary_metrics,
- $process_all_functions,
- $elf_loadobjects_found,
- $outputdir,
- \@sort_fields,
- \@function_info,
- \%function_address_and_index,
- \%LINUX_vDSO,
- \%metric_description,
- $elf_arch,
- $base_va_executable,
- $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats);
+ $msg = "for each function, generate a set of files";
+ gp_message ("verbose", $subr_name, $msg);
+
+ ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) =
+ process_function_files (\@exp_dir_list,
+ $executable_name,
+ $time_percentage_multiplier,
+ $summary_metrics,
+ $process_all_functions,
+ $elf_loadobjects_found,
+ $outputdir,
+ \@sort_fields,
+ \@function_info,
+ \%function_address_and_index,
+ \%LINUX_vDSO,
+ \%metric_description,
+ $elf_arch,
+ $base_va_executable,
+ $ARCHIVES_MAP_NAME,
+ $ARCHIVES_MAP_VADDR,
+ \%elf_rats);
@function_info = @{ $function_info_ref };
%function_address_info = %{ $function_address_info_ref };
%addressobj_index = %{ $addressobj_index_ref };
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Parse the disassembly information and generate the html files.
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files");
+#------------------------------------------------------------------------------
+ $msg = "parse the disassembly files and generate the html files";
+ gp_message ("verbose", $subr_name, $msg);
- $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info,
- \%function_address_and_index,
- \$outputdir, \%addressobj_index);
+ $ignore_value = parse_dis_files (\$number_of_metrics,
+ \@function_info,
+ \%function_address_and_index,
+ \$outputdir,
+ \%addressobj_index);
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Parse the source information and generate the html files.
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Parse the source files and generate the html files");
+#------------------------------------------------------------------------------
+ $msg = "parse the source files and generate the html files";
+ gp_message ("verbose", $subr_name, $msg);
parse_source_files (\$number_of_metrics, \@function_info, \$outputdir);
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Parse the caller-callee information and generate the html files.
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file");
+#------------------------------------------------------------------------------
+ $msg = "process the caller-callee information and generate the html file";
+ gp_message ("verbose", $subr_name, $msg);
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Generate the caller-callee information.
-#-------------------------------------------------------------------------------------
- $ignore_value = generate_caller_callee (
- \$number_of_metrics,
- \@function_info,
- \%function_view_structure,
- \%function_address_info,
- \%addressobjtextm,
- \$outputdir);
-
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+ $ignore_value = generate_caller_callee (\$number_of_metrics,
+ \@function_info,
+ \%function_view_structure,
+ \%function_address_info,
+ \%addressobjtextm,
+ \$outputdir);
+
+#------------------------------------------------------------------------------
# Parse the calltree information and generate the html files.
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
{
- my $msg = "Process the call tree information and generate the html file";
+ $msg = "process the call tree information and generate the html file";
gp_message ("verbose", $subr_name, $msg);
- $ignore_value = process_calltree (
- \@function_info,
- \%function_address_info,
- \%addressobjtextm,
- $outputdir);
+ $ignore_value = process_calltree (\@function_info,
+ \%function_address_info,
+ \%addressobjtextm,
+ $outputdir);
}
-#-------------------------------------------------------------------------------------
-# TBD
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Generate the html file with the metrics information");
+#------------------------------------------------------------------------------
+# Process the metric values.
+#------------------------------------------------------------------------------
+ $msg = "generate the html file with the metrics information";
+ gp_message ("verbose", $subr_name, $msg);
- $ignore_value = process_metrics (
- $outputdir,
- \@sort_fields,
- \%metric_description,
- \%ignored_metrics);
+ $ignore_value = process_metrics ($outputdir,
+ \@sort_fields,
+ \%metric_description,
+ \%ignored_metrics);
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Generate the function view html files.
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Generate the function view html files");
+#------------------------------------------------------------------------------
+ $msg = "generate the function view html files";
+ gp_message ("verbose", $subr_name, $msg);
$html_first_metric_file_ref = generate_function_view (
- \$outputdir,
- \$summary_metrics,
- \$number_of_metrics,
- \@function_info,
- \%function_view_structure,
- \%function_address_info,
- \@sort_fields,
- \@exp_dir_list,
- \%addressobjtextm);
+ \$outputdir,
+ \$summary_metrics,
+ \$number_of_metrics,
+ \@function_info,
+ \%function_view_structure,
+ \%function_address_info,
+ \@sort_fields,
+ \@exp_dir_list,
+ \%addressobjtextm);
$html_first_metric_file = ${ $html_first_metric_file_ref };
- gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file");
+ $msg = "html_first_metric_file = " . $html_first_metric_file;
+ gp_message ("debugXL", $subr_name, $msg);
- my $html_test = ${ generate_home_link ("left") };
- gp_message ("debugXL", $subr_name, "html_test = $html_test");
+ $html_test = ${ generate_home_link ("left") };
+ $msg = "html_test = " . $html_test;
+ gp_message ("debugXL", $subr_name, $msg);
- my $number_of_warnings_ref = create_html_warnings_page (\$outputdir);
+#------------------------------------------------------------------------------
+# Unconditionnaly generate the page with the warnings.
+#------------------------------------------------------------------------------
+ $ignore_value = html_create_warnings_page (\$outputdir);
-#-------------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Generate the index.html file.
-#-------------------------------------------------------------------------------------
- gp_message ("verbose", $subr_name, "Generate the index.html file");
-
- $ignore_value = generate_index (\$outputdir,
- \$html_first_metric_file,
- \$summary_metrics,
- \$number_of_metrics,
- \@function_info,
- \%function_address_info,
- \@sort_fields,
- \@exp_dir_list,
- \%addressobjtextm,
- \%metric_description_reversed,
- $number_of_warnings_ref,
- \@table_execution_stats);
-
-#-------------------------------------------------------------------------------------
-# We're done. In debug mode, print the meta data for the experiment directories.
-#-------------------------------------------------------------------------------------
- $ignore_value = print_meta_data_experiments ("debug");
-
- my $results_file = $abs_path_outputdir . "/index.html";
- my $prologue_text = "Processing completed - view file $results_file in a browser";
- gp_message ("diag", $subr_name, $prologue_text);
-
- return (0);
+#------------------------------------------------------------------------------
+ $msg = "generate the index.html file";
+ gp_message ("verbose", $subr_name, $msg);
-} #-- End of subroutine main
+ $ignore_value = html_generate_index (\$outputdir,
+ \$html_first_metric_file,
+ \$summary_metrics,
+ \$number_of_metrics,
+ \@function_info,
+ \%function_address_info,
+ \@sort_fields,
+ \@exp_dir_list,
+ \%addressobjtextm,
+ \%metric_description_reversed,
+ \@table_execution_stats);
#------------------------------------------------------------------------------
-# Print a message after a failure in $GP_DISPLAY_TEXT.
+# We're done. In debug mode, print the meta data for the experiment
+# directories.
#------------------------------------------------------------------------------
-sub msg_display_text_failure
-{
- my $subr_name = get_my_name ();
-
- my ($gp_display_text_cmd, $error_code, $error_file) = @_;
-
- my $msg;
+ $ignore_value = print_meta_data_experiments ("debug");
- $msg = "error code = $error_code - failure executing the following command:";
- gp_message ("error", $subr_name, $msg);
+#------------------------------------------------------------------------------
+# Before the execution completes, print the warning(s) on the screen.
+#
+# Note that this assumes that no additional warnings have been created since
+# the call to html_create_warnings_page. Otherwise there will be a discrepancy
+# between what is printed on the screen and shown in the warnings.html page.
+#------------------------------------------------------------------------------
+ if (($g_total_warning_count > 0) and ($g_warnings))
+ {
+ $ignore_value = print_warnings_buffer ();
+ @g_warning_msgs = ();
+ }
- gp_message ("error", $subr_name, $gp_display_text_cmd);
+#------------------------------------------------------------------------------
+# This is not supposed to happen, but in case there are any fatal errors that
+# have not caused the execution to terminate, print them here.
+#------------------------------------------------------------------------------
+ if (@g_error_msgs)
+ {
+ $ignore_value = print_errors_buffer (\$g_error_keyword);
+ }
- $msg = "check file $error_file for more details";
- gp_message ("error", $subr_name, $msg);
+#------------------------------------------------------------------------------
+# One line message to show where the results can be found.
+#------------------------------------------------------------------------------
+ my $results_file = $abs_path_outputdir . "/index.html";
+ my $prologue_text = "Processing completed - view file $results_file" .
+ " in a browser";
+ gp_message ("diag", $subr_name, $prologue_text);
return (0);
-} #-- End of subroutine msg_display_text_failure
+} #-- End of subroutine main
#------------------------------------------------------------------------------
# If it is not present, add a "/" to the name of the argument. This is
-# intended to be used for the name of the output directory and makes it
+# intended to be used for the name of the output directory and makes it
# easier to construct pathnames.
#------------------------------------------------------------------------------
sub append_forward_slash
my $length_of_string = length ($input_string);
my $return_string = $input_string;
- if (rindex ($input_string, "/") != $length_of_string-1)
+ if (rindex ($input_string, "/") != $length_of_string-1)
{
$return_string .= "/";
}
} #-- End of subroutine build_pretty_dir_list
#------------------------------------------------------------------------------
-# Calculate the target address in hex by adding the instruction to the
+# Calculate the target address in hex by adding the instruction to the
# instruction address.
#------------------------------------------------------------------------------
sub calculate_target_hex_address
my ($instruction_address, $instruction_offset) = @_;
- my $dec_branch_target;
+ my $dec_branch_target;
my $d1;
my $d2;
my $first_char;
my $length_of_string;
my $mask;
+ my $msg;
my $number_of_fields;
- my $raw_hex_branch_target;
+ my $raw_hex_branch_target;
my $result;
if ($g_addressing_mode eq "64 bit")
}
else
{
- gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n");
+ $msg = "g_addressing_mode = $g_addressing_mode not supported";
+ gp_message ("abort", $subr_name, $msg);
}
-
- $length_of_string = length ($instruction_offset);
+
+ $length_of_string = length ($instruction_offset);
$first_char = lcfirst (substr ($instruction_offset,0,1));
$d1 = bigint::hex ($instruction_offset);
$d2 = bigint::hex ($mask);
} #-- End of subroutine calculate_target_hex_address
#------------------------------------------------------------------------------
-# Sets the absolute path to all commands in array @cmds. The commands and
-# their respective paths are stored in hash "g_mapped_cmds".
+# Sets the absolute path to all commands in array @cmds.
+#
+# First, it is checked if the command is in the search path, built-in, or an
+# alias. If this is not the case, search for it in a couple of locations.
+#
+# If this all fails, warning messages are printed, but this is not a hard
+# error. Yet. Most likely, things will go bad later on.
#
-# If no such mapping is found, a warning is issued, but execution continues.
-# The warning(s) may help with troubleshooting, should a failure occur later.
+# The commands and their respective paths are stored in hash "g_mapped_cmds".
#------------------------------------------------------------------------------
sub check_and_define_cmds
{
my @cmds = @{$cmds_ref};
my @search_path = @{$search_path_ref};
- my $found_match;
- my $target_cmd;
- my $failed_cmd;
- my $no_of_failed_mappings;
+ my @the_fields = ();
+
+ my $cmd;
+ my $cmd_found;
+ my $error_code;
+ my $failed_cmd;
my $failed_cmds;
+ my $found_match;
+ my $mapped;
+ my $msg;
+ my $no_of_failed_mappings;
+ my $no_of_fields;
+ my $output_cmd;
+ my $target_cmd;
+ my $failed_mapping = $FALSE;
+ my $full_path_cmd;
- gp_message ("debug", $subr_name, "\@cmds = @cmds");
- gp_message ("debug", $subr_name, "\@search_path = @search_path");
+ gp_message ("debugXL", $subr_name, "\@cmds = @cmds");
+ gp_message ("debugXL", $subr_name, "\@search_path = @search_path");
#------------------------------------------------------------------------------
-# Search for the command to be in the search path given. In case no such path
+# Search for the command and record the absolute path. In case no such path
# can be found, the entry in $g_mapped_cmds is assigned a special value that
# will be checked for in the next block.
#------------------------------------------------------------------------------
- for my $cmd (@cmds)
+ for $cmd (@cmds)
{
- $found_match = $FALSE;
- for my $path (@search_path)
+ $target_cmd = "(command -v $cmd; echo \$\?)";
+
+ ($error_code, $output_cmd) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+#------------------------------------------------------------------------------
+# This is unlikely to happen, since it means the command executed failed.
+#------------------------------------------------------------------------------
+ {
+ $msg = "error executing this command: " . $target_cmd;
+ gp_message ("warning", $subr_name, $msg);
+ $msg = "execution continues, but may fail later on";
+ gp_message ("warning", $subr_name, $msg);
+
+ $g_total_warning_count++;
+ }
+ else
+#------------------------------------------------------------------------------
+# So far, all is well, but is the target command available?
+#------------------------------------------------------------------------------
{
- $target_cmd = $path . "/" . $cmd;
- if (-x $target_cmd)
+#------------------------------------------------------------------------------
+# The output from the $target_cmd command should contain 2 lines in case the
+# command has been found. The first line shows the command with the full
+# path, while the second line has the exit code.
+#
+# If the exit code is not zero, the command has not been found.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Split the output at the \n character and check the number of lines as
+# well as the return code.
+#------------------------------------------------------------------------------
+ @the_fields = split ("\n", $output_cmd);
+ $no_of_fields = scalar (@the_fields);
+ $cmd_found = ($the_fields[$no_of_fields-1] == 0 ? $TRUE : $FALSE);
+
+#------------------------------------------------------------------------------
+# This is unexpected. Throw an assertion error and bail out.
+#------------------------------------------------------------------------------
+ if ($no_of_fields > 2)
{
- $found_match = $TRUE;
- $g_mapped_cmds{$cmd} = $target_cmd;
- last;
+ gp_message ("error", $subr_name, "output from $target_cmd:");
+ gp_message ("error", $subr_name, $output_cmd);
+
+ $msg = "the output from $target_cmd has more than 2 lines";
+ gp_message ("assertion", $subr_name, $msg);
}
- }
- if (not $found_match)
- {
- $g_mapped_cmds{$cmd} = "road_to_nowhere";
+ if ($cmd_found)
+ {
+ $full_path_cmd = $the_fields[0];
+#------------------------------------------------------------------------------
+# The command is in the search path. Store the full path to the command.
+#------------------------------------------------------------------------------
+ $msg = "the $cmd command is in the search path";
+ gp_message ("debug", $subr_name, $msg);
+
+ $g_mapped_cmds{$cmd} = $full_path_cmd;
+ }
+ else
+#------------------------------------------------------------------------------
+# A best effort to locate the command elsewhere. If found, store the command
+# with the absolute path included. Otherwise print a warning, but continue.
+#------------------------------------------------------------------------------
+ {
+ $msg = "the $cmd command is not in the search path";
+ $msg .= " - start a best effort search to find it";
+ gp_message ("debug", $subr_name, $msg);
+
+ $found_match = $FALSE;
+ for my $path (@search_path)
+ {
+ $target_cmd = $path . "/" . $cmd;
+ if (-x $target_cmd)
+ {
+ $msg = "found the command in $path";
+ gp_message ("debug", $subr_name, $msg);
+
+ $found_match = $TRUE;
+ $g_mapped_cmds{$cmd} = $target_cmd;
+ last;
+ }
+ else
+ {
+ $msg = "failure to find the $cmd command in $path";
+ gp_message ("debug", $subr_name, $msg);
+ }
+ }
+
+ if (not $found_match)
+ {
+ $g_mapped_cmds{$cmd} = "road to nowhere";
+ $failed_mapping = $TRUE;
+ }
+ }
}
}
#------------------------------------------------------------------------------
$no_of_failed_mappings = 0;
$failed_cmds = "";
- while ( my ($cmd, $mapped) = each %g_mapped_cmds)
+
+#------------------------------------------------------------------------------
+# Print a warning message before showing the results, that at least one search
+# has failed.
+#------------------------------------------------------------------------------
+ if ($failed_mapping)
+ {
+ $msg = "<br>" . "failure in the verification of the OS commands:";
+ gp_message ("warning", $subr_name, $msg);
+ }
+
+ while ( ($cmd, $mapped) = each %g_mapped_cmds)
{
- if ($mapped eq "road_to_nowhere")
+ if ($mapped eq "road to nowhere")
{
- my $msg = "cannot find a path for command $cmd - " .
- "assume this will still work without a path";
+ $msg = "cannot find a path for command $cmd";
gp_message ("warning", $subr_name, $msg);
- $no_of_failed_mappings++;
- $failed_cmds .= $cmd;
+ gp_message ("debug", $subr_name, $msg);
+
+ $no_of_failed_mappings++;
+ $failed_cmds .= $cmd;
$g_mapped_cmds{$cmd} = $cmd;
}
else
{
- gp_message ("debug", $subr_name, "path for the $cmd command is $mapped");
+ $msg = "path for the $cmd command is $mapped";
+ gp_message ("debug", $subr_name, $msg);
}
}
if ($no_of_failed_mappings != 0)
{
- gp_message ("debug", $subr_name, "failed to find a mapping for $failed_cmds");
- gp_message ("debug", $subr_name, "a total of $no_of_failed_mappings mapping failures");
+ my $plural_1 = ($no_of_failed_mappings > 1) ? "failures" : "failure";
+ my $plural_2 = ($no_of_failed_mappings > 1) ? "commands" : "command";
+
+ $msg = "encountered $no_of_failed_mappings $plural_1 to locate";
+ $msg .= " selected " . $plural_2;
+ gp_message ("warning", $subr_name, $msg);
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "execution continues, but may fail later on";
+ gp_message ("warning", $subr_name, $msg);
+ gp_message ("debug", $subr_name, $msg);
+
+ $g_total_warning_count++;
}
return ($no_of_failed_mappings);
my $msg;
my $raw_hex_branch_target;
- if ( ($input_line =~ /$g_branch_regex/)
+ if ( ($input_line =~ /$g_branch_regex/)
or ($input_line =~ /$g_endbr_regex/))
{
if (defined ($3))
#------------------------------------------------------------------------------
$instruction_offset = $3;
$raw_hex_branch_target = calculate_target_hex_address (
- $instruction_address,
- $instruction_offset);
+ $instruction_address,
+ $instruction_offset);
$hex_branch_target = "0x" . $raw_hex_branch_target;
$branch_target{$hex_branch_target} = 1;
- $extended_branch_target{$instruction_address} = $raw_hex_branch_target;
+ $extended_branch_target{$instruction_address} =
+ $raw_hex_branch_target;
}
if (defined ($2) and (not defined ($3)))
{
# TBD: Perhaps this should be an assertion or alike.
#------------------------------------------------------------------------------
$branch_target{"0x0000"} = $FALSE;
- gp_message ("debug", $subr_name, "cannot determine branch target");
+ $msg = "cannot determine branch target";
+ gp_message ("debug", $subr_name, $msg);
}
}
else
my %extended_branch_target = %{ $extended_branch_target_ref };
my $found_it = $TRUE;
- my $hex_branch_target;
+ my $hex_branch_target;
my $instruction_address;
my $instruction_offset;
my $msg;
- my $raw_hex_branch_target;
+ my $raw_hex_branch_target;
if ( $input_line =~ /$g_function_call_v2_regex/ )
{
# address.
#------------------------------------------------------------------------------
$raw_hex_branch_target = calculate_target_hex_address (
- $instruction_address,
- $instruction_offset);
+ $instruction_address,
+ $instruction_offset);
$hex_branch_target = "0x" . $raw_hex_branch_target;
$msg = "calculated hex_branch_target = " .
gp_message ("debugXL", $subr_name, $msg);
$branch_target{$hex_branch_target} = 1;
- $extended_branch_target{$instruction_address} = $raw_hex_branch_target;
+ $extended_branch_target{$instruction_address} =
+ $raw_hex_branch_target;
$msg = "set branch_target{$hex_branch_target} to 1";
gp_message ("debugXL", $subr_name, $msg);
- $msg = "added extended_branch_target{$instruction_address}" .
- " = $extended_branch_target{$instruction_address}";
+ $msg = "added extended_branch_target{$instruction_address}";
+ $msg .= " = $extended_branch_target{$instruction_address}";
gp_message ("debugXL", $subr_name, $msg);
}
else
} #-- End of subroutine check_and_proc_dis_func_call
#------------------------------------------------------------------------------
-# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool
-# needed to provide the information. If it can not be found, execution is
+# Check if the value for the user option given is valid.
+#
+# In case the value is valid, the g_user_settings table is updated with the
+# (new) value.
+#
+# Otherwise an error message is pushed into the g_error_msgs buffer.
+#
+# The return value is TRUE/FALSE.
+#------------------------------------------------------------------------------
+sub check_and_set_user_option
+{
+ my $subr_name = get_my_name ();
+
+ my ($internal_opt_name, $value) = @_;
+
+ my $msg;
+ my $valid;
+ my $option_value_missing;
+
+ my $option = $g_user_settings{$internal_opt_name}{"option"};
+ my $data_type = $g_user_settings{$internal_opt_name}{"data_type"};
+ my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"};
+
+ if (($no_of_args >= 1) and
+ ((not defined ($value)) or (length ($value) == 0)))
+#------------------------------------------------------------------------------
+# If there was no value given, but it is required, flag an error.
+# There could also be a value, but it might be the empty string.
+#
+# Note that that there are currently no options with multiple values. Should
+# these be introduced, the current check may need to be refined.
+#------------------------------------------------------------------------------
+ {
+ $valid = $FALSE;
+ $option_value_missing = $TRUE;
+ }
+ elsif ($no_of_args >= 1)
+ {
+ $option_value_missing = $FALSE;
+#------------------------------------------------------------------------------
+# There is an input value. Check if it is valid and if so, store it.
+#
+# Note that we allow the options to be case insensitive.
+#------------------------------------------------------------------------------
+ $valid = verify_if_input_is_valid ($value, $data_type);
+
+ if ($valid)
+ {
+ if (($data_type eq "onoff") or ($data_type eq "size"))
+ {
+ $g_user_settings{$internal_opt_name}{"current_value"} =
+ lc ($value);
+ }
+ else
+ {
+ $g_user_settings{$internal_opt_name}{"current_value"} = $value;
+ }
+ $g_user_settings{$internal_opt_name}{"defined"} = $TRUE;
+ }
+ }
+
+ return (\$valid, \$option_value_missing);
+
+} #-- End of subroutine check_and_set_user_option
+
+#------------------------------------------------------------------------------
+# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool
+# needed to provide the information. If it can not be found, execution is
# terminated.
#
-# We first search foe this tool in the current execution directory. If it
+# We first search for this tool in the current execution directory. If it
# cannot be found there, use $PATH to try to locate it.
#------------------------------------------------------------------------------
sub check_availability_tool
my $error_code;
my $error_occurred;
+ my $gp_path;
my $msg;
my $output_which_gp_display_text;
my $return_value;
#------------------------------------------------------------------------------
# Get the path to gp-display-text.
#------------------------------------------------------------------------------
- my ($error_occurred_ref, $return_value_ref) = find_path_to_gp_display_text (
- $location_gp_command_ref
- );
- $error_occurred = ${ $error_occurred_ref};
+ my ($error_occurred_ref, $gp_path_ref, $return_value_ref) =
+ find_path_to_gp_display_text ($location_gp_command_ref);
+
+ $error_occurred = ${ $error_occurred_ref};
+ $gp_path = ${ $gp_path_ref };
$return_value = ${ $return_value_ref};
$msg = "error_occurred = $error_occurred return_value = $return_value";
gp_message ("debugXL", $subr_name, $msg);
- if (not $error_occurred)
+ if (not $error_occurred)
#------------------------------------------------------------------------------
# All is well and gp-display-text has been located.
#------------------------------------------------------------------------------
{
$g_path_to_tools = $return_value;
- $msg = "located $GP_DISPLAY_TEXT in execution directory";
+ $msg = "located $GP_DISPLAY_TEXT in the execution directory";
gp_message ("debug", $subr_name, $msg);
$msg = "g_path_to_tools = $g_path_to_tools";
gp_message ("debug", $subr_name, $msg);
# $GP_DISPLAY_TEXT through the search path.
#------------------------------------------------------------------------------
{
- $msg = "error accessing $GP_DISPLAY_TEXT: $return_value - " .
- "run time behaviour may be undefined";
+ $msg = $g_html_new_line;
+ $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :";
+ $msg .= " $return_value";
gp_message ("warning", $subr_name, $msg);
-
+
#------------------------------------------------------------------------------
# Check if we can find $GP_DISPLAY_TEXT in the search path.
#------------------------------------------------------------------------------
- $msg = "check for $GP_DISPLAY_TEXT in search path";
+ $msg = "check for $GP_DISPLAY_TEXT to be in the search path";
gp_message ("debug", $subr_name, $msg);
+ gp_message ("warning", $subr_name, $msg);
+ $g_total_warning_count++;
+
$target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1";
- ($error_code, $output_which_gp_display_text) =
- execute_system_cmd ($target_cmd);
-
+ ($error_code, $output_which_gp_display_text) =
+ execute_system_cmd ($target_cmd);
+
if ($error_code == 0)
{
- my ($gp_file_name, $gp_path, $suffix_not_used) =
+ my ($gp_file_name, $gp_path, $suffix_not_used) =
fileparse ($output_which_gp_display_text);
$g_path_to_tools = $gp_path;
- $msg = "using $GP_DISPLAY_TEXT in $g_path_to_tools instead";
+ $msg = "located $GP_DISPLAY_TEXT in $g_path_to_tools";
+ gp_message ("warning", $subr_name, $msg);
+ $msg = "this is the version that will be used";
gp_message ("warning", $subr_name, $msg);
$msg = "the $GP_DISPLAY_TEXT tool is in the search path";
gp_message ("debug", $subr_name, $msg);
$msg = "g_path_to_tools = $g_path_to_tools";
gp_message ("debug", $subr_name, $msg);
- }
+ }
else
{
$msg = "failure to find $GP_DISPLAY_TEXT in the search path";
- gp_message ("debug", $subr_name, $msg);
+ gp_message ("error", $subr_name, $msg);
- $msg = "fatal error executing command $target_cmd";
- gp_message ("abort", $subr_name, $msg);
+ $g_total_error_count++;
+
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
}
# This function determines whether load objects are in ELF format.
#
# Compared to the original code, any input value other than 2 or 3 is rejected
-# upfront. This not only reduces the nesting level, but also eliminates a
+# upfront. This not only reduces the nesting level, but also eliminates a
# possible bug.
#
# Also, by isolating the tests for the input files, another nesting level could
my ($selected_archive) = @_;
+ my $event_kind_map_regex;
+ $event_kind_map_regex = '^<event kind="map"\s.*vaddr=';
+ $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset=';
+ $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes=';
+ $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$';
+
my $hostname_current = $local_system_config{"hostname_current"};
my $arch = $local_system_config{"processor"};
my $arch_uname_s = $local_system_config{"kernel_name"};
- my $extracted_information;
+ my $extracted_information;
my $elf_magic_number;
my $executable_name;
my $va_executable_in_hex;
-
+
my $arch_exp;
my $hostname_exp;
my $os_exp;
my $rc_b;
my $file;
my $line;
+ my $msg;
my $name;
my $name_path;
my $foffset;
my $vaddr;
my $modes;
- my $path_to_map_file;
+ my $path_to_map_file;
my $path_to_log_file;
#------------------------------------------------------------------------------
# TBD: Parameterize and should be the first experiment directory from the list.
#------------------------------------------------------------------------------
- $path_to_log_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
+ $path_to_log_file =
+ $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
$path_to_log_file .= $selected_archive;
$path_to_log_file .= "/log.xml";
# This check can probably be removed since the presence of the log.xml file is
# checked for in an earlier phase.
#------------------------------------------------------------------------------
+ $msg = " - unable to open file $path_to_log_file for reading:";
open (LOG_XML, "<", $path_to_log_file)
- or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'");
- gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading");
-
+ or die ($subr_name . $msg . " " . $!);
+
+ $msg = "opened file $path_to_log_file for reading";
+ gp_message ("debug", $subr_name, $msg);
+
while (<LOG_XML>)
{
$line = $_;
chomp ($line);
- gp_message ("debug", $subr_name, "read line: $line");
+ gp_message ("debugM", $subr_name, "read line: $line");
#------------------------------------------------------------------------------
# Search for the first line starting with "<system". Bail out if found and
# parsed. These are two examples:
-# <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514">
-# <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968">
+# <system hostname="ruud-vm" arch="x86_64" \
+# os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514">
#------------------------------------------------------------------------------
if ($line =~ /^\s*<system\s+/)
{
- gp_message ("debug", $subr_name, "selected the following line from the log.xml file:");
- gp_message ("debug", $subr_name, "$line");
+ $msg = "selected the following line from the log.xml file:";
+ gp_message ("debugM", $subr_name, $msg);
+ gp_message ("debugM", $subr_name, "$line");
if ($line =~ /.*\s+hostname="([^"]+)/)
{
$hostname_exp = $1;
- gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp");
+ $msg = "extracted hostname_exp = " . $hostname_exp;
+ gp_message ("debugM", $subr_name, $msg);
}
if ($line =~ /.*\s+arch="([^"]+)/)
{
$arch_exp = $1;
- gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp");
+ $msg = "extracted arch_exp = " . $arch_exp;
+ gp_message ("debugM", $subr_name, $msg);
}
if ($line =~ /.*\s+os="([^"]+)/)
{
{
$os_exp = $1;
}
- gp_message ("debug", $subr_name, "extracted os_exp = $os_exp");
+ $msg = "extracted os_exp = " . $os_exp;
+ gp_message ("debugM", $subr_name, $msg);
}
last;
}
#TBD: THIS DOES NOT CHECK IF ELF IS FOUND!
if (($hostname_current eq $hostname_exp) and
- ($arch eq $arch_exp) and
+ ($arch eq $arch_exp) and
($arch_uname_s eq $os_exp))
{
- gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system");
- gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE");
+ $msg = "early return: the hostname, architecture and OS match";
+ $msg .= " the current system";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE";
+ gp_message ("debug", $subr_name, $msg);
# FAKE return ($TRUE);
}
if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"})
{
- gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
- for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}})
+ $msg = "selected_archive = " . $selected_archive;
+ gp_message ("debug", $subr_name, $msg);
+ for my $i (sort keys
+ %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}})
{
- gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}");
+ $msg = "stored loadobject " . $i . " ";
+ $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i};
+ gp_message ("debug", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
# Check if the selected experiment directory has archived files in ELF format.
-# If not, use the information in map.xml to get the name of the executable
+# If not, use the information in map.xml to get the name of the executable
# and the virtual address.
#------------------------------------------------------------------------------
if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"})
{
- gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format");
- gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML");
+ $msg = "the files in directory $selected_archive/archives are in";
+ $msg .= " ELF format";
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "IGNORE THIS AND USE MAP.XML";
+ gp_message ("debugM", $subr_name, $msg);
## return ($TRUE);
}
- gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format");
+ $msg = "the files in directory $selected_archive/archives are not in";
+ $msg .= " ELF format";
+ gp_message ("debug", $subr_name, $msg);
- $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
- $path_to_map_file .= $selected_archive;
- $path_to_map_file .= "/map.xml";
+ $path_to_map_file =
+ $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
+ $path_to_map_file .= $selected_archive;
+ $path_to_map_file .= "/map.xml";
- open (MAP_XML, "<", $path_to_map_file)
- or die ($subr_name, "unable to open file $path_to_map_file for reading: $!");
- gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading");
+ $msg = " - unable to open file $path_to_map_file for reading:";
+ open (MAP_XML, "<", $path_to_map_file)
+ or die ($subr_name . $msg . " " . $!);
+ $msg = "opened file $path_to_map_file for reading";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Scan the map.xml file. We need to find the name of the executable with the
# mode set to 0x005. For this entry we have to capture the virtual address.
#------------------------------------------------------------------------------
- $extracted_information = $FALSE;
- while (<MAP_XML>)
+ $extracted_information = $FALSE;
+ while (<MAP_XML>)
{
$line = $_;
chomp ($line);
- gp_message ("debug", $subr_name, "MAP_XML read line = $line");
-## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
- if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
+ gp_message ("debugM", $subr_name, "MAP_XML read line = $line");
+#------------------------------------------------------------------------------
+# Replaces this way too long line:
+# if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.
+# *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*
+# name="(.*)".*>$/)
+#------------------------------------------------------------------------------
+ if ($line =~ /$event_kind_map_regex/)
{
- gp_message ("debug", $subr_name, "target line = $line");
+ gp_message ("debugM", $subr_name, "target line = $line");
$vaddr = $1;
$foffset = $2;
$modes = $3;
$name_path = $4;
$name = get_basename ($name_path);
- gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes");
- gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name");
+ $msg = "extracted vaddr = $vaddr foffset = $foffset";
+ $msg .= " modes = $modes";
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "extracted name_path = $name_path name = $name";
+ gp_message ("debugM", $subr_name, $msg);
# $error_extracting_information = $TRUE;
$executable_name = $name;
my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset);
my $hex_VA = sprintf ("0x%016x", $result_VA);
$va_executable_in_hex = $hex_VA;
- gp_message ("debug", $subr_name, "set executable_name = $executable_name");
- gp_message ("debug", $subr_name, "set va_executable_in_hex = $va_executable_in_hex");
- gp_message ("debug", $subr_name, "result_VA = $result_VA");
- gp_message ("debug", $subr_name, "hex_VA = $hex_VA");
+
+ $msg = "set executable_name = " . $executable_name;
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "set va_executable_in_hex = " . $va_executable_in_hex;
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "result_VA = " . $result_VA;
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "hex_VA = " . $hex_VA;
+ gp_message ("debugM", $subr_name, $msg);
+
if ($modes eq "005")
{
$extracted_information = $TRUE;
}
}
}
+
+ close (MAP_XML);
+
if (not $extracted_information)
{
- my $msg = "cannot find the necessary information in the $path_to_map_file file";
+ $msg = "cannot find the necessary information in";
+ $msg .= " the $path_to_map_file file";
gp_message ("assertion", $subr_name, $msg);
}
my $current_value;
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
my $max_value;
+ my $msg;
my $relative_distance;
- @current_metrics = split (" ", $metric_values);
+ @current_metrics = split (" ", $metric_values);
$colour_coded_line = $FALSE;
+
for my $metric (0 .. $#current_metrics)
{
$current_value = $current_metrics[$metric];
if (exists ($max_metric_values[$metric]))
{
$max_value = $max_metric_values[$metric];
- gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
- if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) )
+
+ $msg = "metric = $metric current_value = $current_value";
+ $msg .= " max_value = $max_value";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ if ( ($max_value > 0) and ($current_value > 0) and
+ ($current_value != $max_value) )
{
# TBD: abs needed?
- gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
- $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
- gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance");
+ $msg = "metric = $metric current_value = $current_value";
+ $msg .= " max_value = $max_value";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ $relative_distance = 1.00 - abs (
+ ($max_value - $current_value)/$max_value );
+
+ $msg = "relative_distance = $relative_distance";
+ gp_message ("debugXL", $subr_name, $msg);
+
if ($relative_distance >= $hp_value/100.0)
{
- gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
+ $msg = "metric $metric is within the relative_distance";
+ gp_message ("debugXL", $subr_name, $msg);
+
$colour_coded_line = $TRUE;
last;
}
} #-- End of subroutine check_support_for_processor
#------------------------------------------------------------------------------
-# Check if the value for the user option given is valid.
+# Check the command line options for the occurrence of experiments and make
+# sure that this list is contigious. No other names are allowed in this list.
#
-# In case the value is valid, the g_user_settings table is updated.
-# Otherwise an error message is printed.
+# Terminate execution in case of an error. Otherwise remove the experiment
+# names for ARGV (to make the subsequent parsing easier), and return an array
+# with the experiment names.
#
-# The return value is TRUE/FALSE.
+# The following patterns are supposed to be detected:
+#
+# <expdir_1> some other word(s) <expdir_2>
+# <expdir> some other word(s)
#------------------------------------------------------------------------------
-sub check_user_option
+sub check_the_experiment_list
{
my $subr_name = get_my_name ();
- my ($internal_option_name, $value) = @_;
-
- my $message;
- my $return_value;
+#------------------------------------------------------------------------------
+# The name of an experiment directory can contain any non-whitespace
+# character(s), but has to end with .er, or optionally .er/. Multiple
+# forward slashes are allowed.
+#------------------------------------------------------------------------------
+ my $exp_dir_regex = '^(\S+)(\.er)\/*$';
+ my $forward_slash_regex = '\/*$';
- my $option = $g_user_settings{$internal_option_name}{"option"};
- my $data_type = $g_user_settings{$internal_option_name}{"data_type"};
- my $no_of_arguments = $g_user_settings{$internal_option_name}{"no_of_arguments"};
+ my $current_value;
+ my @exp_dir_list = ();
+ my $found_experiment = $FALSE;
+ my $found_non_exp = $FALSE;
+ my $msg;
+ my $name_non_exp_dir = "";
+ my $no_of_experiments = 0;
+ my $no_of_invalid_dirs = 0;
+ my $opt_remainder;
+ my $valid = $TRUE;
- if (($no_of_arguments >= 1) and
- ((not defined ($value)) or (length ($value) == 0)))
+ for my $i (keys @ARGV)
{
+ $current_value = $ARGV[$i];
+ if ($current_value =~ /$exp_dir_regex/)
#------------------------------------------------------------------------------
-# If there was no value given, but it is required, flag an error.
-# There could also be a value, but it might be the empty string.
-#
-# Note that that there are currently no options with multiple values. Should
-# these be introduced, the current check may need to be refined.
+# The current value is an experiment. Remove any trailing forward slashes,
+# Increment the count, push the value into the array and set the
+# found_experiment flag to TRUE.
#------------------------------------------------------------------------------
+ {
+ $no_of_experiments += 1;
- $message = "the $option option requires a value";
- push (@g_user_input_errors, $message);
- $return_value = $FALSE;
- }
- elsif ($no_of_arguments >= 1)
- {
+ $current_value =~ s/$forward_slash_regex//;
+ push (@exp_dir_list, $current_value);
+
+ if (not $found_experiment)
#------------------------------------------------------------------------------
-# There is an input value. Check if it is valid and if so, store it.
-#
-# Note that we allow the options to be case insensitive.
+# Start checking for the next field(s).
#------------------------------------------------------------------------------
- my $valid = verify_if_input_is_valid ($value, $data_type);
-
- if ($valid)
- {
- if (($data_type eq "onoff") or ($data_type eq "size"))
{
- $g_user_settings{$internal_option_name}{"current_value"} = lc ($value);
+ $found_experiment = $TRUE;
}
- else
- {
- $g_user_settings{$internal_option_name}{"current_value"} = $value;
+#------------------------------------------------------------------------------
+# We had found non-experiment names and now see another experiment. Time to
+# bail out of the loop.
+#------------------------------------------------------------------------------
+ if ($found_non_exp)
+ {
+ last;
+ }
+ }
+ else
+ {
+ if ($found_experiment)
+#------------------------------------------------------------------------------
+# The current value is not an experiment, but the value of found_experiment
+# indicates at least one experiment has been seen already. This means that
+# the list of experiment names is not contiguous and that is a fatal error.
+#------------------------------------------------------------------------------
+ {
+ $name_non_exp_dir .= $current_value . " ";
+ $found_non_exp = $TRUE;
+ }
+ }
+
+ }
+
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Error handling.
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+
+ if ($found_non_exp)
+#------------------------------------------------------------------------------
+# The experiment list is not contiguous.
+#------------------------------------------------------------------------------
+ {
+ $valid = $FALSE;
+ $msg = "the list with the experiments is not contiguous:";
+ gp_message ("error", $subr_name, $msg);
+
+ $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" .
+ " appears in a list where experiments are expected";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+
+ if ($no_of_experiments == 0)
+#------------------------------------------------------------------------------
+# The experiment list is empty.
+#------------------------------------------------------------------------------
+ {
+ $valid = $FALSE;
+ $msg = "the experiment list is missing from the options";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+
+ if (not $valid)
+#------------------------------------------------------------------------------
+# If an error has occurred, print the error(s) and terminate execution.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("abort", $subr_name, $g_abort_msg);
+ }
+
+#------------------------------------------------------------------------------
+# We now have a list with experiments, but we still need to verify whether they
+# exist, and if so, are these valid experiments?
+#------------------------------------------------------------------------------
+ for my $exp_dir (@exp_dir_list)
+ {
+ $msg = "checking experiment directory $exp_dir";
+ gp_message ("debug", $subr_name, $msg);
+
+ if (-d $exp_dir)
+ {
+ $msg = "directory $exp_dir found";
+ gp_message ("debug", $subr_name, $msg);
+#------------------------------------------------------------------------------
+# Files log.xml and map.xml have to be there.
+#------------------------------------------------------------------------------
+ if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml"))
+ {
+ $msg = "directory $exp_dir appears to be a valid experiment";
+ $msg .= " directory";
+ gp_message ("debug", $subr_name, $msg);
+ }
+ else
+ {
+ $no_of_invalid_dirs++;
+ $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir;
+ $msg .= "/map.xml missing";
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "directory " . get_basename($exp_dir) . " does not";
+ $msg .= " appear to be a valid experiment directory";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
}
- $g_user_settings{$internal_option_name}{"defined"} = $TRUE;
- $return_value = $TRUE;
}
else
{
- $message = "incorrect value for $option option: $value";
- push (@g_user_input_errors, $message);
+ $no_of_invalid_dirs++;
+ $msg = "directory " . get_basename($exp_dir) . " does not exist";
+ gp_message ("error", $subr_name, $msg);
- $return_value = $FALSE;
+ $g_total_error_count++;
}
}
- return ($return_value);
+ if ($no_of_invalid_dirs > 0)
+#------------------------------------------------------------------------------
+# This is a fatal error, but for now, we can continue to check for more errors.
+# Even if none more are found, execution is terminated before the data is
+# generated and processed. In this way we can catch as many errors as
+# possible.
+#------------------------------------------------------------------------------
+ {
+ my $plural_or_single = ($no_of_invalid_dirs == 1) ?
+ "one experiment is" : $no_of_invalid_dirs . " experiments are";
+
+ $msg = $plural_or_single . " not valid";
+## gp_message ("abort", $subr_name, $msg);
-} #-- End of subroutine check_user_option
+## $g_total_error_count++;
+ }
+
+#------------------------------------------------------------------------------
+# Remove the experiments from ARGV and return the array with the experiment
+# names. Note that these may, or may not be valid, but if invalid, execution
+# terminates before they are used.
+#------------------------------------------------------------------------------
+ for my $i (1 .. $no_of_experiments)
+ {
+ my $poppy = pop (@ARGV);
+
+ $msg = "popped $poppy from ARGV";
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "ARGV after update = " . join (" ", @ARGV);
+ gp_message ("debug", $subr_name, $msg);
+ }
+
+ return (\@exp_dir_list);
+
+} #-- End of subroutine check_the_experiment_list
-#-------------------------------------------------------------------------------
-# This subroutine performs multiple checks on the experiment directories. One
-# or more failures are fatal.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Perform multiple checks on the experiment directories.
+#
+# TBD: It needs to be investigated whether all of this is really neccesary.
+#------------------------------------------------------------------------------
sub check_validity_exp_dirs
{
my $subr_name = get_my_name ();
my ($exp_dir_list_ref) = @_;
my @exp_dir_list = @{ $exp_dir_list_ref };
-
+
my %elf_rats = ();
my $dir_not_found = $FALSE;
- my $invalid_dir = $FALSE;
- my $dir_check_errors = $FALSE;
my $missing_dirs = 0;
my $invalid_dirs = 0;
-
+
my $archive_dir_not_empty;
- my $elf_magic_number;
+ my $archives_dir;
my $archives_file;
- my $archives_dir;
- my $first_line;
my $count_exp_dir_not_elf;
-
+ my $elf_magic_number;
+ my $first_line;
+ my $msg;
+
my $first_time;
my $filename;
my $comment;
- my $selected_archive_has_elf_format;
+ my $selected_archive_has_elf_format;
my $selected_archive;
my $archive_dir_selected;
my $no_of_files_in_selected_archive;
-#-------------------------------------------------------------------------------
-# Check if the experiment directories exist and are valid.
-#-------------------------------------------------------------------------------
- for my $exp_dir (@exp_dir_list)
- {
- if (not -d $exp_dir)
- {
- $dir_not_found = $TRUE;
- $missing_dirs++;
- gp_message ("error", $subr_name, "directory $exp_dir not found");
- $dir_check_errors = $TRUE;
- }
- else
- {
-#-------------------------------------------------------------------------------
-# Files log.xml and map.xml have to be there.
-#-------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "directory $exp_dir found");
- if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml"))
- {
- gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory");
- }
- else
- {
- $invalid_dir = $TRUE;
- $invalid_dirs++;
- gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing");
- gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory");
- $dir_check_errors = $TRUE;
- }
- }
- }
- if ($dir_not_found)
- {
- gp_message ("error", $subr_name, "a total of $missing_dirs directories not found");
- }
- if ($invalid_dir)
- {
- gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid");
- }
-
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Initialize ELF status to FALSE.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
## for my $exp_dir (@exp_dir_list)
for my $exp_dir (keys %g_exp_dir_meta_data)
{
- $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE;
- $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
+ $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Check if the load objects are in ELF format.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
for my $exp_dir (keys %g_exp_dir_meta_data)
{
- $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives";
+ $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
+ $archives_dir .= $exp_dir . "/archives";
$archive_dir_not_empty = $FALSE;
$first_time = $TRUE;
$g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE;
$g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0;
- gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
- gp_message ("debug", $subr_name, "checking $archives_dir");
+ $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = ";
+ $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'};
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "checking $archives_dir";
+ gp_message ("debug", $subr_name, $msg);
while (glob ("$archives_dir/*"))
{
$filename = get_basename ($_);
- gp_message ("debug", $subr_name, "processing file: $filename");
+
+ $msg = "processing file: $filename";
+ gp_message ("debug", $subr_name, $msg);
$g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE;
$g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++;
$archive_dir_not_empty = $TRUE;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Replaces the ELF_RATS part in elf_phdr.
#
# Challenge: splittable_mrg.c_I0txnOW_Wn5
#
# TBD: Store this for each relevant experiment directory.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $last_dot = rindex ($filename,".");
my $underscore_before_dot = $TRUE;
my $first_underscore = -1;
- gp_message ("debugXL", $subr_name, "last_dot = $last_dot");
+
+ $msg = "last_dot = $last_dot";
+ gp_message ("debugXL", $subr_name, $msg);
+
while ($underscore_before_dot)
{
$first_underscore = index ($filename, "_", $first_underscore+1);
}
}
my $original_name = substr ($filename, 0, $first_underscore);
- gp_message ("debug", $subr_name, "stripped archive name: $original_name");
+ $msg = "stripped archive name: " . $original_name;
+ gp_message ("debug", $subr_name, $msg);
if (not exists ($elf_rats{$original_name}))
{
$elf_rats{$original_name} = [$filename, $exp_dir];
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# We only need to detect the presence of an object once.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($first_time)
{
$first_time = $FALSE;
$g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE;
- gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
+ $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = ";
+ $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
+
+ gp_message ("debugXL", $subr_name, $msg);
}
}
} #-- End of loop over experiment directories
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
- my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
- gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty"));
+ my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
+ $msg = "archive directory " . $exp_dir . "/archives is";
+ $msg .= " " . ($empty ? "empty" : "not empty");
+ gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
- $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
{
- $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives";
- gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir");
+ $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
+ $archives_dir .= $exp_dir . "/archives";
+ $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir;
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Check if any of the loadobjects is of type ELF. Bail out on the first one
# found. The assumption is that all other loadobjects must be of type ELF too
# then.
#------------------------------------------------------------------------------
- for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
+ for my $aname (sort keys
+ %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
{
- $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives/" . $aname;
+ $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
+ $filename .= $exp_dir . "/archives/" . $aname;
+ $msg = " - unable to open file $filename for reading:";
open (ARCF,"<", $filename)
- or die ("unable to open file $filename for reading - '$!'");
+ or die ($subr_name . $msg . " " . $!);
$first_line = <ARCF>;
close (ARCF);
# if ($first_line =~ /^\177ELF.*/)
$elf_magic_number = unpack ('H8', $first_line);
-# gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number");
if ($elf_magic_number eq "7f454c46")
{
- $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} =
+ $TRUE;
$g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE;
last;
}
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
- $comment = "the loadobjects in the archive in $exp_dir are ";
- $comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in ";
- $comment .= "ELF format";
- gp_message ("debug", $subr_name, $comment);
+ $msg = "the loadobjects in the archive in $exp_dir are";
+ $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ?
+ " in" : " not in";
+ $msg .= " ELF format";
+ gp_message ("debug", $subr_name, $msg);
}
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
{
- gp_message ("debug", $subr_name, "there are no archived files in $exp_dir");
+ $msg = "there are no archived files in " . $exp_dir;
+ gp_message ("debug", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
-# If there are archived files and they are not in ELF format, a debug is
-# issued.
+# If there are archived files and they are not in ELF format, a debug message
+# is issued.
#
# TBD: Bail out?
#------------------------------------------------------------------------------
{
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"})
{
- $count_exp_dir_not_elf++;
+ $count_exp_dir_not_elf++;
}
}
if ($count_exp_dir_not_elf != 0)
{
- gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects");
+ $msg = "there are $count_exp_dir_not_elf experiments with non-ELF";
+ $msg .= " load objects";
+ gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
## for my $exp_dir (sort @exp_dir_list)
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
- gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir");
- gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
+ $msg = "exp_dir = " . $exp_dir;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}";
+ $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
+ gp_message ("debugXL", $subr_name, $msg);
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
{
$selected_archive = $exp_dir;
$archive_dir_not_empty = $TRUE;
$archive_dir_selected = $TRUE;
- $selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE;
+ $selected_archive_has_elf_format =
+ ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ?
+ $TRUE : $FALSE;
last;
}
}
- if (not $archive_dir_selected)
+ if (not $archive_dir_selected)
#------------------------------------------------------------------------------
# None are found and pick the first one without archived files.
#------------------------------------------------------------------------------
}
}
}
- gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis");
- gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty"));
- gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format");
+
+ $msg = "experiment $selected_archive has been selected for";
+ $msg .= " archive analysis";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "this archive is";
+ $msg .= $archive_dir_not_empty ? " not empty" : " empty";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "this archive is";
+ $msg .= $selected_archive_has_elf_format ? " in" : " not in";
+ $msg .= " ELF format";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Get the size of the hash that contains the archived files.
#------------------------------------------------------------------------------
## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES);
- $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"};
- gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive");
+ $no_of_files_in_selected_archive =
+ $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"};
+ $msg = "number of files in archive $selected_archive is";
+ $msg .= " " . $no_of_files_in_selected_archive;
+ gp_message ("debug", $subr_name, $msg);
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
- gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty"));
+ $msg = "archive directory $exp_dir/archives is";
+ $msg .= $is_empty ? " empty" : " not empty";
+ gp_message ("debug", $subr_name, $msg);
}
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
{
- for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
+ for my $object (sort keys
+ %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
{
- gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}");
+ $msg = $exp_dir . " " . $object . " ";
+ $msg .=
+ $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object};
+ gp_message ("debug", $subr_name, $msg);
}
}
}
- return ($dir_check_errors, $archive_dir_not_empty, $selected_archive, \%elf_rats);
+ return ($archive_dir_not_empty, $selected_archive, \%elf_rats);
} #-- End of subroutine check_validity_exp_dirs
{
$colored_string .= "</b>";
}
- $colored_string .= "</font>";
+ $colored_string .= "</font>";
return ($colored_string);
my @experiment_data = @{ $experiment_data_ref };
my @experiment_stats_html = ();
- my $experiment_stats_line;
+ my $experiment_stats_line;
+ my $msg;
my $plural;
$plural = ($#experiment_dir_list > 0) ? "s:" : ":";
$experiment_stats_line = "<h3>\n";
- $experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n";
+ $experiment_stats_line .= "Full pathnames to the input experiment";
+ $experiment_stats_line .= $plural . "\n";
$experiment_stats_line .= "</h3>\n";
$experiment_stats_line .= "<pre>\n";
for my $i (0 .. $#experiment_dir_list)
{
- $experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n";
+ $experiment_stats_line .= $experiment_dir_list[$i] . " (" ;
+ $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n";
}
$experiment_stats_line .= "</pre>\n";
push (@experiment_stats_html, $experiment_stats_line);
- gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --");
+ $msg = "experiment_stats_line = " . $experiment_stats_line;
+ gp_message ("debugXL", $subr_name, $msg);
return (\@experiment_stats_html);
my $msg;
my $the_date;
- my @months = qw (January February March April May June July August September October November December);
+ my @months = qw (January February March April May June July
+ August September October November December);
- my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime ();
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ localtime ();
$year += 1900;
my $title = ${ $title_ref };
my $LANG = $g_locale_settings{"LANG"};
- my $background_color = $g_html_color_scheme{"background_color_page"};
+ my $background_color = $g_html_color_scheme{"background_color_page"};
- my $html_header;
+ my $html_header;
$html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n";
$html_header .= "<html lang=\"$LANG\">\n";
$html_header .= "<head>\n";
- $html_header .= "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n";
+ $html_header .= "<meta http-equiv=\"content-type\"";
+ $html_header .= " content=\"text/html; charset=iso-8859-1\">\n";
$html_header .= "<title>" . $title . "</title>\n";
$html_header .= "</head>\n";
- $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n";
+ $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n";
$html_header .= "<style>\n";
$html_header .= "div.left {\n";
$html_header .= "text-align: left;\n";
} #-- End of subroutine create_html_header
#------------------------------------------------------------------------------
-# Create an HTML page with the warnings. If there are no warnings, include
-# line to this extent. The alternative is to supporess the entire page, but
-# that breaks the consistency in the output.
-#------------------------------------------------------------------------------
-sub create_html_warnings_page
-{
- my $subr_name = get_my_name ();
-
- my ($outputdir_ref) = @_;
-
- my $outputdir = ${ $outputdir_ref };
-
- my $file_title;
- my $html_acknowledgement;
- my $html_end;
- my $html_header;
- my $html_home_left;
- my $html_home_right;
- my $html_title_header;
- my $msg_no_warnings = "There are no warning messages issued.";
- my $page_title;
- my $position_text;
- my $size_text;
-
- my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html";
-
- gp_message ("debug", $subr_name, "outfile = $outfile");
-
- open (WARNINGS_OUT, ">", $outfile)
- or die ("unable to open $outfile for writing - '$!'");
- gp_message ("debug", $subr_name, "opened file $outfile for writing");
-
- gp_message ("debug", $subr_name, "building warning file $outfile");
-
-#------------------------------------------------------------------------------
-# Get the number of warnings and in debug mode, print the list.
-#------------------------------------------------------------------------------
- my $number_of_warnings = scalar (@g_warning_messages);
- gp_message ("debug", $subr_name, "number_of_warnings = $number_of_warnings");
-
- if ($number_of_warnings > 0)
- {
- for my $i (0 .. $#g_warning_messages)
- {
- print "$g_warning_messages[$i]\n";
- my $msg = "g_warning_messages[$i] = $g_warning_messages[$i]";
- gp_message ("debug", $subr_name, $msg);
- }
- }
-
-#------------------------------------------------------------------------------
-# Generate some of the structures used in the HTML output.
-#------------------------------------------------------------------------------
- $file_title = "Warning messages";
- $html_header = ${ create_html_header (\$file_title) };
- $html_home_right = ${ generate_home_link ("right") };
-
- $page_title = "Warning Messages";
- $size_text = "h2";
- $position_text = "center";
- $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
-
-#-------------------------------------------------------------------------------
-# Get the acknowledgement, return to main link, and final html statements.
-#-------------------------------------------------------------------------------
- $html_home_left = ${ generate_home_link ("left") };
- $html_acknowledgement = ${ create_html_credits () };
- $html_end = ${ terminate_html_document () };
-
-#-------------------------------------------------------------------------------
-# Generate the HTML file.
-#-------------------------------------------------------------------------------
- print WARNINGS_OUT $html_header;
- print WARNINGS_OUT $html_home_right;
- print WARNINGS_OUT $html_title_header;
-
- if ($number_of_warnings > 0)
- {
- print WARNINGS_OUT "<pre>\n";
- print WARNINGS_OUT "$_\n" for @g_warning_messages;
- print WARNINGS_OUT "</pre>\n";
- }
- else
- {
- print WARNINGS_OUT $msg_no_warnings;
- }
-
- print WARNINGS_OUT $html_home_left;
- print WARNINGS_OUT "<br>\n";
- print WARNINGS_OUT $html_acknowledgement;
- print WARNINGS_OUT $html_end;
-
- close (WARNINGS_OUT);
-
- return (\$number_of_warnings);
-
-} #-- End of subroutine create_html_warnings_page
-
-#-------------------------------------------------------------------------------
# Create a complete table.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub create_table
{
my $subr_name = get_my_name ();
my ($experiment_data_ref, $table_definition_ref) = @_;
-
+
my @experiment_data = @{ $experiment_data_ref };
my @table_definition = @{ $table_definition_ref };
for my $i (sort keys @table_definition)
{
- $html_table_line = ${ create_table_entry_exp (\$table_definition[$i]{"name"},
- \$table_definition[$i]{"key"}, \@experiment_data) };
+ $html_table_line = ${
+ create_table_entry_exp (\$table_definition[$i]{"name"},
+ \$table_definition[$i]{"key"},
+ \@experiment_data) };
push (@html_exp_table_data, $html_table_line);
my $msg = "i = $i html_table_line = $html_table_line";
} #-- End of subroutine create_table
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Create one row for the table with experiment info.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub create_table_entry_exp
{
my $subr_name = get_my_name ();
my $key = ${ $key_ref };
my @experiment_data = @{ $experiment_data_ref };
- gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key");
-
my $html_line;
+ my $msg;
+
+ $msg = "entry_name = $entry_name key = $key";
+ gp_message ("debugXL", $subr_name, $msg);
- $html_line = "<tr><div class=\"left\"><td><b> ";
+
## $html_line = "<tr><div class=\"left\"><td><b> ";
$html_line = "<tr><div class=\"right\"><td><b> ";
$html_line .= $entry_name;
$html_line .= " </b></td>";
{
if (exists ($experiment_data[$i]{$key}))
{
- $html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>";
+ $html_line .= "<td> " . $experiment_data[$i]{$key};
+ $html_line .= " </td>";
}
else
{
-## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist");
- gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist");
+ $msg = "experiment_data[$i]{$key} does not exist";
+## gp_message ("assertion", $subr_name, $msg);
+# TBD: warning or error?
+ gp_message ("warning", $subr_name, $msg);
}
}
$html_line .= "</div></tr>\n";
} #-- End of subroutine create_table_entry_exp
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Create the table header for the experiment info.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub create_table_header_exp
{
my $subr_name = get_my_name ();
my @experiment_data = @{ $experiment_data_ref };
my $html_header_line;
+ my $msg;
$html_header_line = "<style>\n";
$html_header_line .= "table, th, td {\n";
for my $i (sort keys @experiment_data)
{
- $html_header_line .= "<th> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>";
+ $html_header_line .= "<th> Experiment ID ";
+ $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>";
}
$html_header_line .= "</div></tr>\n";
- gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line");
+ $msg = "html_header_line = " . $html_header_line;
+ gp_message ("debugXL", $subr_name, $msg);
return (\$html_header_line);
} #-- End of subroutine create_table_header_exp
-#-------------------------------------------------------------------------------
-# Handle where the output should go. If needed, a directory is created where
+#------------------------------------------------------------------------------
+# Handle where the output should go. If needed, a directory is created where
# the results will go.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub define_the_output_directory
{
my $subr_name = get_my_name ();
my ($define_new_output_dir, $overwrite_output_dir) = @_;
+ my $msg;
my $outputdir;
-#-------------------------------------------------------------------------------
-# If neither -o or -O are set, find the next number to be used in the name for
+#------------------------------------------------------------------------------
+# If neither -o or -O are set, find the next number to be used in the name for
# the default output directory.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ((not $define_new_output_dir) and (not $overwrite_output_dir))
{
my $dir_id = 1;
- while (-d "er.".$dir_id.".html")
+ while (-d "er.".$dir_id.".html")
{ $dir_id++; }
$outputdir = "er.".$dir_id.".html";
}
if (-d $outputdir)
{
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The -o option is used, but the directory already exists.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($define_new_output_dir)
{
- gp_message ("error", $subr_name, "directory $outputdir already exists");
- gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory");
+ $msg = "directory $outputdir already exists";
+ gp_message ("error", $subr_name, $msg);
+ $g_total_error_count++;
+
+ $msg = "use the -O/--overwrite option to overwrite an existing";
+ $msg .= " directory";
+ gp_message ("abort", $subr_name, $msg);
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This is a bit risky, so we proceed with caution. The output directory exists,
# but it is okay to overwrite it. It is removed here and created again below.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
elsif ($overwrite_output_dir)
{
my $target_cmd = $g_mapped_cmds{"rm"};
if ($error_code != 0)
{
gp_message ("error", $subr_name, $rm_output);
- gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
+ $msg = "fatal error when trying to remove " . $outputdir;
+ gp_message ("abort", $subr_name, $msg);
}
else
{
- gp_message ("debug", $subr_name, "directory $outputdir has been removed");
+ $msg = "directory $outputdir has been removed";
+ gp_message ("debug", $subr_name, $msg);
}
}
}
-#-------------------------------------------------------------------------------
-# When we get here, the fatal scenarios have been cleared and the name for
+#------------------------------------------------------------------------------
+# When we get here, the fatal scenarios have been cleared and the name for
# $outputdir is known. Time to create it.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if (mkdir ($outputdir, 0777))
{
- gp_message ("debug", $subr_name, "created output directory $outputdir");
+ $msg = "created output directory " . $outputdir;
+ gp_message ("debug", $subr_name, $msg);
}
- else
+ else
{
- gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir");
+ $msg = "a fatal problem occurred when creating directory " . $outputdir;
+ gp_message ("abort", $subr_name, $msg);
}
return ($outputdir);
my ($executable_name, $base_va_executable, $loadobj, $routine) = @_;
+ my $msg;
my $name_loadobject;
my $base_va_address;
- gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable");
- gp_message ("debugXL", $subr_name, "loadobj = $loadobj");
- gp_message ("debugXL", $subr_name, "routine = $routine");
-
-#------------------------------------------------------------------------------
+ $msg = "base_va_executable = " . $base_va_executable;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "loadobj = " . $loadobj;
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "routine = " . $routine;
+ gp_message ("debugXL", $subr_name, $msg);
+
+#------------------------------------------------------------------------------
# Strip the pathname from the load object name.
#------------------------------------------------------------------------------
$name_loadobject = get_basename ($loadobj);
#------------------------------------------------------------------------------
-# If the load object is the executable, return the base address determined
+# If the load object is the executable, return the base address determined
# earlier. Otherwise return 0x0. Note that I am not sure if this is always
# the right thing to do, but for .so files it seems to work out fine.
#------------------------------------------------------------------------------
{
$base_va_address = "0x0";
}
-
+
my $decimal_address = bigint::hex ($base_va_address);
- gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)");
+
+ $msg = "return base_va_address = $base_va_address";
+ $msg .= " (decimal: $decimal_address)";
+ gp_message ("debugXL", $subr_name, $msg);
return ($base_va_address);
} #-- End of subroutine determine_base_va_address
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Now that we know the map.xml file(s) are present, we can scan these and get
# the required information.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub determine_base_virtual_address
{
my $subr_name = get_my_name ();
my @exp_dir_list = @{ $exp_dir_list_ref };
- my $full_path_exec;
my $executable_name;
+ my $full_path_exec;
+ my $msg;
+ my $path_to_map_file;
my $va_executable_in_hex;
- my $path_to_map_file;
-
for my $exp_dir (keys %g_exp_dir_meta_data)
{
- $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
+ $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
$path_to_map_file .= $exp_dir;
$path_to_map_file .= "/map.xml";
- ($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file);
+ ($full_path_exec, $executable_name, $va_executable_in_hex) =
+ extract_info_from_map_xml ($path_to_map_file);
$g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec;
$g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name;
$g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex;
- gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
- gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec");
- gp_message ("debug", $subr_name, "executable_name = $executable_name");
- gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+ $msg = "exp_dir = " . $exp_dir;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "full_path_exece = " . $full_path_exec;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "executable_name = " . $executable_name;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "va_executable_in_hex = " . $va_executable_in_hex;
+ gp_message ("debug", $subr_name, $msg);
}
return (0);
{
my $subr_name = get_my_name ();
- my $ignore_count;
- my $decimal_separator;
+ my $cmd_output;
my $convert_to_dot;
- my $field;
- my $target_found;
+ my $decimal_separator;
my $error_code;
- my $cmd_output;
+ my $field;
+ my $ignore_count;
+ my @locale_info = ();
+ my $msg;
my $target_cmd;
- my @locale_info;
+ my $target_found;
my $default_decimal_separator = "\\.";
$target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC";
($error_code, $cmd_output) = execute_system_cmd ($target_cmd);
-
+
if ($error_code != 0)
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This is unlikely to happen, but you never know. To reduce the nesting level,
# return right here in case of an error.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- gp_message ("error", $subr_name, "failure to execute the command $target_cmd");
-
+ $msg = "failure to execute the command " . $target_cmd;
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+
$convert_to_dot = $TRUE;
return ($error_code, $default_decimal_separator, $convert_to_dot);
}
-#-------------------------------------------------------------------------------
-# Scan the locale info and search for the target line of the form
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Scan the locale info and search for the target line of the form
# decimal_point="<target>" where <target> is either a dot, or a comma.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Split the output into the different lines and scan for the line we need.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
@locale_info = split ("\n", $cmd_output);
$target_found = $FALSE;
- for my $line (@locale_info)
+ for my $line (@locale_info)
{
chomp ($line);
- gp_message ("debug", $subr_name, "line from locale_info = $line");
- if ($line =~ /decimal_point=/)
+ $msg = "line from locale_info = " . $line;
+ gp_message ("debug", $subr_name, $msg);
+
+ if ($line =~ /decimal_point=/)
{
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Found the target line. Split this line to get the value field.
-#-------------------------------------------------------------------------------
- my @split_line = split ("=", $line);
+#------------------------------------------------------------------------------
+ my @split_line = split ("=", $line);
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# There should be 2 fields. If not, something went wrong.
-#-------------------------------------------------------------------------------
- if (scalar @split_line != 2)
+#------------------------------------------------------------------------------
+ if (scalar @split_line != 2)
{
# if (scalar @split_line == 2) {
# $target_found = $FALSE;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Remove the newline before printing the variables.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$ignore_count = chomp ($line);
$ignore_count = chomp (@split_line);
- gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format");
- gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields");
- gp_message ("debug", $subr_name, "warning - the default decimal separator will be used");
+
+ $msg = "line $line matches the search, but the decimal";
+ $msg .= " separator has the wrong format";
+ gp_message ("warning", $subr_name, $msg);
+ $msg = "the splitted line is [@split_line] and does not";
+ $msg .= " contain 2 fields";
+ gp_message ("warning", $subr_name, $msg);
+ $msg = "the default decimal separator will be used";
+ gp_message ("warning", $subr_name, $msg);
+
+ $g_total_warning_count++;
}
else
{
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# We know there are 2 fields and the second one has the decimal point.
-#-------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]");
+#------------------------------------------------------------------------------
+ $msg = "split_line[1] = " . $split_line[1];
+ gp_message ("debug", $subr_name, $msg);
chomp ($split_line[1]);
$field = $split_line[1];
if (length ($field) != 3)
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The field still includes the quotes. Check if the string has length 3, which
# should be the case, but if not, we flag an error. The error code is set such
# that the callee will know a problem has occurred.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field");
+ $msg = "unexpected output from the $target_cmd command:";
+ $msg .= " " . $field;
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+
$error_code = 1;
last;
}
- gp_message ("debug", $subr_name, "field = ->$field<-");
+ $msg = "field = ->$field<-";
+ gp_message ("debug", $subr_name, $msg);
if (($field eq "\".\"") or ($field eq "\",\""))
-#-------------------------------------------------------------------------------
-# Found the separator. Capture the character between the quotes.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Found the separator. Capture the character between the quotes.
+#------------------------------------------------------------------------------
{
$target_found = $TRUE;
$decimal_separator = substr ($field,1,1);
- gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop");
+ $msg = "decimal_separator = $decimal_separator--end";
+ $msg .= " skip remainder of loop";
+ gp_message ("debug", $subr_name, $msg);
last;
}
}
}
}
- if (not $target_found)
+ if (not $target_found)
{
$decimal_separator = $default_decimal_separator;
- gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator");
- }
+ $msg = "cannot determine the decimal separator";
+ $msg .= " - use the default " . $decimal_separator;
+ gp_message ("warning", $subr_name, $msg);
+
+ $g_total_warning_count++;
+ }
if ($decimal_separator ne ".")
{
my %function_info = %{$function_info_ref};
my $kip;
+ my $msg;
+
+ $msg = "function_info for " . $name;
+ gp_message ("debug", $subr_name, $msg);
- gp_message ("debug", $subr_name, "function_info for $name");
$kip = 0;
for my $farray ($function_info{$name})
{
for my $elm (@{$farray})
{
- gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}");
+ $msg = $kip . ": routine = " . ${$elm}{"routine"};
+ gp_message ("debug", $subr_name, $msg);
for my $key (sort keys %{$elm})
{
if ($key eq "routine")
{
next;
}
- gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}");
+ $msg = $kip . ": $key = " . ${$elm}{$key};
+ gp_message ("debug", $subr_name, $msg);
}
$kip++;
}
} #-- End of subroutine dump_function_info
-#------------------------------------------------------------------------------
-# This is an early scan to find the settings for some options very early on.
-# For practical reasons the main option parsing and handling is done later,
-# but without this early scan, these options will not be enabled until later
-# in the execution.
-#
-# This early scan fixes that, but it is not very elegant to do it this way
-# and in the future, this will be improved. For now it gets the job done.
-#------------------------------------------------------------------------------
-sub early_scan_specific_options
-{
- my $subr_name = get_my_name ();
-
- my @options_with_value = qw /verbose warnings debug quiet/;
- my $target_option;
-
- my $ignore_value;
- my $found_option;
- my $option_requires_value;
- my $option_value;
- my $valid_input;
- my @error_messages = ();
-
- $option_requires_value = $TRUE;
- for (@options_with_value)
- {
- $target_option = $_;
- ($found_option, $option_value) = find_target_option (
- \@ARGV,
- $option_requires_value,
- $target_option);
- if ($found_option)
- {
-#------------------------------------------------------------------------------
-# This part has been set up such that we can support other options too, should
-# this become necessary.
-#
-# A necessary, but limited check for the validity of a value is performed.
-# This avoids that an error message shows up twice later on.
-#------------------------------------------------------------------------------
-
-#------------------------------------------------------------------------------
-# All option values are converted to lower case. This makes the checks easier.
-#------------------------------------------------------------------------------
-
- if ($target_option eq "verbose")
- {
- my $verbose_value = lc ($option_value);
- $valid_input = verify_if_input_is_valid ($verbose_value, "onoff");
- if ($valid_input)
- {
- $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
- if ($verbose_value eq "on")
-#------------------------------------------------------------------------------
-# Set the status and disable output buffering in verbose mode.
-#------------------------------------------------------------------------------
- {
- $g_user_settings{"verbose"}{"current_value"} = "on";
- STDOUT->autoflush (1);
- }
- elsif ($verbose_value eq "off")
- {
- $g_user_settings{"verbose"}{"current_value"} = "off";
- }
- }
- else
- {
- my $msg = "$option_value is not supported for the verbose option";
- push (@error_messages, $msg);
- }
- }
- elsif ($target_option eq "warnings")
- {
- my $warnings_value = lc ($option_value);
- $valid_input = verify_if_input_is_valid ($warnings_value, "onoff");
- if ($valid_input)
- {
- $g_warnings = ($warnings_value eq "on") ? $TRUE : $FALSE;
- if ($warnings_value eq "on")
-#------------------------------------------------------------------------------
-# Set the status and disable output buffering if warnings are enabled.
-#------------------------------------------------------------------------------
- {
- $g_user_settings{"warnings"}{"current_value"} = "on";
- STDOUT->autoflush (1);
- }
- elsif ($warnings_value eq "off")
- {
- $g_user_settings{"warnings"}{"current_value"} = "off";
- }
- }
- else
- {
- my $msg = "$option_value is not supported for the warnings option";
- push (@error_messages, $msg);
- }
- }
- elsif ($target_option eq "quiet")
- {
- my $quiet_value = lc ($option_value);
- $valid_input = verify_if_input_is_valid ($option_value, "onoff");
- if ($valid_input)
- {
- $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
- if ($quiet_value eq "on")
- {
- $g_user_settings{"quiet"}{"current_value"} = "on";
- }
- elsif ($quiet_value eq "off")
- {
- $g_user_settings{"quiet"}{"current_value"} = "off";
- }
- }
- else
- {
- my $msg = "$option_value is not supported for the quiet option";
- push (@error_messages, $msg);
- }
- }
- elsif ($target_option eq "debug")
- {
- my $debug_value = lc ($option_value);
- $valid_input = verify_if_input_is_valid ($debug_value, "size");
- if ($valid_input)
- {
- if ($debug_value ne "off")
-#------------------------------------------------------------------------------
-# Disable output buffering in debug mode.
-#------------------------------------------------------------------------------
- {
- $g_user_settings{"debug"}{"current_value"} = "on";
- STDOUT->autoflush (1);
- }
-#------------------------------------------------------------------------------
-# This function also sets $g_user_settings{"debug"}{"current_value"}.
-#------------------------------------------------------------------------------
- my $ignore_value = set_debug_size (\$debug_value);
- }
- else
- {
- my $msg = "$option_value is not supported for the debug option";
- push (@error_messages, $msg);
- }
- }
- else
- {
- my $msg = "target option $target_option not expected";
- gp_message ("assertion", $subr_name, $msg);
- }
- }
- }
-
-#------------------------------------------------------------------------------
-# Check for input errors.
-#------------------------------------------------------------------------------
- my $input_errors = scalar (@error_messages);
- if ($input_errors > 0)
- {
- my $plural = ($input_errors == 1) ?
- "is one error" : "are $input_errors errors";
- print "There " . $plural . " in the options:\n";
- for my $i (0 .. $#error_messages)
- {
- print "- $error_messages[$i]\n";
- }
- exit (0);
- }
-#------------------------------------------------------------------------------
-# If quiet mode has been enabled, disable verbose, warnings and debug.
-#------------------------------------------------------------------------------
- if ($g_quiet)
- {
- $g_user_settings{"verbose"}{"current_value"} = "off";
- $g_user_settings{"warnings"}{"current_value"} = "off";
- $g_user_settings{"debug"}{"current_value"} = "off";
- $g_verbose = $FALSE;
- $g_warnings = $FALSE;
- my $debug_off = "off";
- my $ignore_value = set_debug_size (\$debug_off);
- }
-
- return (0);
-
-} #-- End of subroutine early_scan_specific_options
-
#------------------------------------------------------------------------------
# TBD
#------------------------------------------------------------------------------
{
my $subr_name = get_my_name ();
- my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine,
+ my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine,
$ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
my %elf_rats = %{$elf_rats_ref};
+ my $msg;
my $return_value;
#------------------------------------------------------------------------------
# TBD. Quick check. Can be moved up the call tree.
#------------------------------------------------------------------------------
- if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") )
+ if ( $elf_arch ne "Linux" )
{
- gp_message ("abort", $subr_name, "$elf_arch is not a supported OS");
+ $msg = $elf_arch . " is not a supported OS";
+ gp_message ("error", $subr_name, $msg);
+ $g_total_error_count++;
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
#------------------------------------------------------------------------------
if ($elf_loadobjects_found)
{
gp_message ("debugXL", $subr_name, "calling elf_phdr_usual");
- $return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats);
+ $return_value = elf_phdr_usual ($elf_arch,
+ $loadobj,
+ $routine,
+ \%elf_rats);
}
- else
+ else
{
gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes");
- $return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR);
+ $return_value = elf_phdr_sometimes ($elf_arch,
+ $loadobj,
+ $routine,
+ $ARCHIVES_MAP_NAME,
+ $ARCHIVES_MAP_VADDR);
}
gp_message ("debug", $subr_name, "the return value = $return_value");
if (not $return_value)
{
- gp_message ("abort", $subr_name, "need to handle a return value of FALSE");
- }
+ $msg = "need to handle a return value of FALSE";
+ gp_message ("error", $subr_name, $msg);
+ $g_total_error_count++;
+ gp_message ("abort", $subr_name, $g_abort_msg);
+ }
+
return ($return_value);
} #-- End of subroutine elf_phdr
{
my $subr_name = get_my_name ();
- my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME,
+ my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME,
$ARCHIVES_MAP_VADDR) = @_;
my $arch_uname_s = $local_system_config{"kernel_name"};
gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
gp_message ("debug", $subr_name, "arch = $arch");
- my $target_cmd;
- my $command_string;
- my $error_code;
my $cmd_output;
+ my $command_string;
+ my $error_code;
+ my $msg;
+ my $target_cmd;
my $line;
my $blo;
if ($ARCHIVES_MAP_NAME eq $blo)
{
return ($ARCHIVES_MAP_VADDR);
- }
- else
+ }
+ else
{
return ($FALSE);
}
#------------------------------------------------------------------------------
# We are masquerading between systems, must leave
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
+ $msg = "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch";
+ gp_message ("debug", $subr_name, $msg);
return ($FALSE);
}
+
if ($loadobj eq "DYNAMIC_FUNCTIONS")
#------------------------------------------------------------------------------
# Linux vDSO, leave for now
if ($ARCHIVES_MAP_NAME eq $blo)
{
return ($ARCHIVES_MAP_VADDR);
- }
- else
+ }
+ else
{
return ($FALSE);
}
my %elf_rats = %{$elf_rats_ref};
+ my $load_long_regex;
+ $load_long_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)';
+ $load_long_regex .= '\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$';
+ my $load_short_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$';
+ my $re_regex = '^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$';
+
my $return_code;
my $cmd_output;
my $target_cmd;
- my $command_string;
+ my $command_string;
my $error_code;
my $error_code1;
my $error_code2;
+ my $msg;
my ($elf_offset, $loadobjARC);
my ($i, @foo, $foo, $foo1, $p_vaddr, $rc);
my $arch_uname_s = $local_system_config{"kernel_name"};
- gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine");
+ $msg = "elf_arch = $elf_arch loadobj = $loadobj routine = $routine";
+ gp_message ("debug", $subr_name, $msg);
my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj);
- gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj));
+
+ $msg = "base = $base " . basename ($loadobj);
+ gp_message ("debug", $subr_name, $msg);
if ($elf_arch eq "Linux")
{
# We are masquerading between systems, must leave.
# Maybe we could use ELF_RATS
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
+ $msg = "masquerading arch_uname_s->" . $arch_uname_s;
+ $msg .= " elf_arch->" . $elf_arch;
+ gp_message ("debug", $subr_name, $msg);
+
return ($FALSE);
}
if ($loadobj eq "DYNAMIC_FUNCTIONS")
($error_code1, $cmd_output) = execute_system_cmd ($command_string);
- gp_message ("debug", $subr_name, "executed command_string = $command_string");
- gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
+ $msg = "executed command_string = " . $command_string;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "cmd_output = " . $cmd_output;
+ gp_message ("debug", $subr_name, $msg);
if ($error_code1 != 0)
{
if (exists ($elf_rats{$loadobjARC}))
{
- my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]";
+ my $elfoid;
+ $elfoid = $elf_rats{$loadobjARC}[1] . "/archives/";
+ $elfoid .= $elf_rats{$loadobjARC}[0];
$target_cmd = $g_mapped_cmds{"readelf"};
$command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null";
- ($error_code2, $cmd_output) = execute_system_cmd ($command_string);
-
+ ($error_code2, $cmd_output) =
+ execute_system_cmd ($command_string);
+
if ($error_code2 != 0)
{
- gp_message ("abort", $subr_name, "call failure for $command_string");
+ $msg = "call failure for " . $command_string;
+ gp_message ("error", $subr_name, $msg);
+ $g_total_error_count++;
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
else
{
- gp_message ("debug", $subr_name, "executed command_string = $command_string");
- gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
+ $msg = "executed command_string = " . $command_string;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "cmd_output = " . $cmd_output;
+ gp_message ("debug", $subr_name, $msg);
}
}
- else
+ else
{
- my $msg = "elf_rats{$loadobjARC} does not exist";
+ $msg = "elf_rats{$loadobjARC} does not exist";
gp_message ("assertion", $subr_name, $msg);
}
}
# Elf file type is EXEC (Executable file)
# Entry point 0x4023a0
# There are 11 program headers, starting at offset 64
-#
+#
# Program Headers:
# Type Offset VirtAddr PhysAddr
# FileSiz MemSiz Flags Align
# 0x0000000000000000 0x0000000000000000 RW 10
# GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
# 0x0000000000000238 0x0000000000000238 R 1
-#
+#
# Section to Segment mapping:
# Segment Sections...
# 00
# 01 .interp
-# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt
+# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym
+# .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt
# 03 .init .plt .text .fini
# 04 .rodata .eh_frame_hdr .eh_frame
# 05 .init_array .fini_array .dynamic .got .got.plt .data .bss
# 0x0000000000001010 0x0000000000001010 R E 200000
#------------------------------------------------------------------------------
@foo = split ("\n",$cmd_output);
- for $i (0 .. $#foo)
+ for $i (0 .. $#foo)
{
$foo = $foo[$i];
chomp ($foo);
- if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
+ if ($foo =~ /$load_long_regex/)
{
$Offset = $1;
$VirtAddr = $2;
$Align = $7;
$elf_offset = $VirtAddr;
- gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset");
+ $msg = "single line version elf_offset = " . $elf_offset;
+ gp_message ("debug", $subr_name, $msg);
return ($elf_offset);
}
- elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/)
- {
+ elsif ($foo =~ /$load_short_regex/)
+ {
#------------------------------------------------------------------------------
# is it a two line version?
#------------------------------------------------------------------------------
$PhysAddr = $3;
if ($i != $#foo)
{
- $foo1 = $foo[$i + 1];
+ $foo1 = $foo[$i + 1];
chomp ($foo1);
- if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
+ if ($foo1 =~ /$re_regex/)
{
$FileSiz = $1;
$MemSiz = $2;
$Flg = $3;
$Align = $4;
$elf_offset = $VirtAddr;
- gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset");
+ $msg = "two line version elf_offset = " . $elf_offset;
+ gp_message ("debug", $subr_name, $msg);
return ($elf_offset);
}
}
}
}
}
- elsif ($elf_arch eq "SunOS")
- {
-#------------------------------------------------------------------------------
-#Program Header[3]:
-# p_vaddr: 0x10000 p_flags: [ PF_X PF_R ]
-# folowed by
-# p_paddr: 0 p_type: [ PT_LOAD ]
-#------------------------------------------------------------------------------
- if ($arch_uname_s ne $elf_arch)
-#------------------------------------------------------------------------------
-# we are masquerading between systems, must leave
-#------------------------------------------------------------------------------
- {
- gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch");
- return (0);
- }
- $target_cmd = $g_mapped_cmds{"elfdump"};
- $command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null";
- ($error_code, $cmd_output) = execute_system_cmd ($command_string);
- if ($error_code != 0)
- {
- gp_message ("debug", $subr_name,"call failure for $command_string");
- die ("$target_cmd call failure");
- }
- my @foo = split ("\n",$cmd_output);
- for $i (0 .. $#foo)
- {
- $foo = $foo[$i];
- chomp ($foo);
- if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/)
- {
- $p_vaddr = $1; # probably
- if ($i != $#foo)
- {
- $foo1 = $foo[$i + 1];
- chomp ($foo1);
- if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/)
- {
- $elf_offset = $p_vaddr;
- return ($elf_offset);
- }
- }
- }
- }
- }
} #-- End of subroutine elf_phdr_usual
my ($target_cmd) = @_;
+ my $cmd_output;
+ my $error_code;
+ my $msg;
+
chomp ($target_cmd);
- my $cmd_output = qx ($target_cmd);
- my $error_code = ${^CHILD_ERROR_NATIVE};
+ $cmd_output = qx ($target_cmd);
+ $error_code = ${^CHILD_ERROR_NATIVE};
if ($error_code != 0)
{
- gp_message ("error", $subr_name, "failure executing command $target_cmd");
- gp_message ("error", $subr_name, "error code = $error_code");
+ chomp ($cmd_output);
+ $msg = "failure executing command " . $target_cmd;
+ gp_message ("error", $subr_name, $msg);
+ $msg = "error code = " . $error_code;
+ gp_message ("error", $subr_name, $msg);
+ $msg = "cmd_output = " . $cmd_output;
+
+ gp_message ("error", $subr_name, $msg);
+ $g_total_error_count++;
}
else
{
- chomp ($cmd_output);
- gp_message ("debugM", $subr_name, "executed command $target_cmd");
- gp_message ("debugM", $subr_name, "cmd_output = $cmd_output");
+ $msg = "executed command " . $target_cmd;
+ gp_message ("debugXL", $subr_name, $msg);
}
return ($error_code, $cmd_output);
} #-- End of subroutine execute_system_cmd
#------------------------------------------------------------------------------
-# Scan the input file, which should be a gprofng generated map.xml file, and
+# Scan the input file, which should be a gprofng generated map.xml file, and
# extract the relevant information.
#------------------------------------------------------------------------------
sub extract_info_from_map_xml
my ($input_map_xml_file) = @_;
+ my $map_xml_regex;
+ $map_xml_regex = '<event kind="map"\s.*';
+ $map_xml_regex .= 'vaddr="0x([0-9a-fA-F]+)"\s+.*';
+ $map_xml_regex .= 'foffset="\+*0x([0-9a-fA-F]+)"\s.*';
+ $map_xml_regex .= 'modes="0x([0-9]+)"\s.*';
+ $map_xml_regex .= 'name="(.*)".*>$';
+
my $extracted_information;
my $input_line;
my $vaddr;
my $foffset;
+ my $msg;
my $modes;
my $name_path;
my $name;
my $full_path_exec;
my $executable_name;
- my $va_executable_in_hex;
+ my $result_VA;
+ my $va_executable_in_hex;
+ $msg = "- unable to open file $input_map_xml_file for reading:";
open (MAP_XML, "<", $input_map_xml_file)
- or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!");
- gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading");
+ or die ($subr_name . $msg . " " . $!);
+
+ $msg = "opened file $input_map_xml_file for reading";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
-# Scan the file. We need to find the name of the executable with the mode set
-# to 0x005. For this entry we have to capture the name, the mode, the virtual
+# Scan the file. We need to find the name of the executable with the mode set
+# to 0x005. For this entry we have to capture the name, the mode, the virtual
# address and the offset.
#------------------------------------------------------------------------------
$extracted_information = $FALSE;
{
$input_line = $_;
chomp ($input_line);
- gp_message ("debug", $subr_name, "read input_line = $input_line");
- if ($input_line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
+
+ $msg = "read input_line = $input_line";
+ gp_message ("debug", $subr_name, $msg);
+
+ if ($input_line =~ /^$map_xml_regex/)
{
- gp_message ("debug", $subr_name, "target line = $input_line");
+ $msg = "target line = $input_line";
+ gp_message ("debug", $subr_name, $msg);
$vaddr = $1;
$foffset = $2;
$modes = $3;
$name_path = $4;
$name = get_basename ($name_path);
- gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes");
- gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name");
+
+ $msg = "extracted vaddr = $vaddr foffset = $foffset";
+ $msg .= " modes = $modes";
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "extracted name_path = $name_path name = $name";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
-# The base virtual address is calculated as vaddr-foffset. Although Perl
+# The base virtual address is calculated as vaddr-foffset. Although Perl
# handles arithmetic in hex, we take the safe way here. Maybe overkill, but
# I prefer to be safe than sorry in cases like this.
#------------------------------------------------------------------------------
- $full_path_exec = $name_path;
- $executable_name = $name;
- my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset);
+ $full_path_exec = $name_path;
+ $executable_name = $name;
+ $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset);
$va_executable_in_hex = sprintf ("0x%016x", $result_VA);
## $ARCHIVES_MAP_NAME = $name;
## $ARCHIVES_MAP_VADDR = $va_executable_in_hex;
-## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
-## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
- gp_message ("debug", $subr_name, "result_VA = $result_VA");
- gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+ $msg = "result_VA = $result_VA";
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "va_executable_in_hex = $va_executable_in_hex";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Stop reading when we found the correct entry.
if (not $extracted_information)
{
- my $msg = "cannot find the necessary information in file $input_map_xml_file";
+ $msg = "cannot find the necessary information in file";
+ $msg .= " " . $input_map_xml_file;
gp_message ("assertion", $subr_name, $msg);
}
- gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec");
- gp_message ("debug", $subr_name, "executable_name = $executable_name");
- gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+ $msg = "full_path_exec = $full_path_exec";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "executable_name = $executable_name";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "va_executable_in_hex = $va_executable_in_hex";
+ gp_message ("debug", $subr_name, $msg);
return ($full_path_exec, $executable_name, $va_executable_in_hex);
} #-- End of subroutine extract_info_from_map_xml
#------------------------------------------------------------------------------
-# This routine analyzes the metric line and extracts the metric specifics
+# This routine analyzes the metric line and extracts the metric specifics
# from it.
# Example input: Exclusive Total CPU Time: e.%totalcpu
#------------------------------------------------------------------------------
# $metric_spec =~ s/\%//;
# print "DB: after \$metric_spec = $metric_spec\n";
- return ($metric_spec, $metric_flavor, $metric_visibility,
+ return ($metric_spec, $metric_flavor, $metric_visibility,
$metric_name, $metric_description);
}
else
} #-- End of subroutine extract_metric_specifics
#------------------------------------------------------------------------------
-# TBD
+# Extract the option value(s) from the input array. In case the number of
+# values execeeds the specified limit, warning messages are printed.
+#
+# In case the option value is valid, g_user_settings is updated with this
+# value and a value of TRUE is returned. Otherwise the return value is FALSE.
+#
+# Note that not in all invocations of this subroutine, gp_message() is
+# operational. Only after the debug settings have been finalized, the
+# messages are printed.
+#
+# This subroutine also generates warnings about multiple occurrences
+# and the validity of the values.
#------------------------------------------------------------------------------
-sub extract_source_line_number
+sub extract_option_value
{
my $subr_name = get_my_name ();
- my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_;
+ my ($option_dir_ref, $max_occurrences_ref, $internal_option_name_ref,
+ $option_name_ref) = @_;
+
+ my @option_dir = @{ $option_dir_ref };
+ my $max_occurrences = ${ $max_occurrences_ref };
+ my $internal_option_name = ${ $internal_option_name_ref };
+ my $option_name = ${ $option_name_ref };
+
+ my $deprecated_option_used;
+ my $excess_occurrences;
+ my $msg;
+ my $no_of_occurrences;
+ my $no_of_warnings = 0;
+ my $option_value = "not set yet";
+ my $option_value_missing;
+ my $option_value_missing_ref;
+ my $reset_blank_value;
+ my $special_treatment = $FALSE;
+ my $valid = $FALSE;
+ my $valid_ref;
+
+ if (@option_dir)
+ {
+ $no_of_occurrences = scalar (@option_dir);
+
+ $msg = "option_name = $option_name";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "internal_option_name = $internal_option_name";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "no_of_occurrences = $no_of_occurrences";
+ gp_message ("debug", $subr_name, $msg);
+
+ $excess_occurrences = ($no_of_occurrences > $max_occurrences) ?
+ $TRUE : $FALSE;
#------------------------------------------------------------------------------
-# The regex section.
+# This is not supposed to happen, but just to be sure, there is a check.
#------------------------------------------------------------------------------
- my $find_dot_regex = '\.';
-
- my @fields_in_line = ();
- my $hot_line;
- my $line_id;
+ if ($no_of_occurrences < 1)
+ {
+ $msg = "the number of fields is $no_of_occurrences";
+ $msg .= " - should at least be 1";
+ gp_message ("assertion", $subr_name, $msg);
+ }
#------------------------------------------------------------------------------
-# To extract the source line number, we need to distinguish whether this is
-# a line with, or without metrics.
+# For backward compatibility, we support the legacy "on" and "off" values for
+# certain options.
+#
+# We also support the debug option without value. In case no value is given,
+# it is set to "on".
+#
+# Note that regardless of the value(s) in ARGV, internally we use the on/off
+# setting.
#------------------------------------------------------------------------------
- @fields_in_line = split (" ", $input_line);
- if ( $input_line =~ /$src_times_regex/ )
+ if (($g_user_settings{$internal_option_name}{"data_type"} eq "onoff") or
+ ($internal_option_name eq "debug"))
{
- $hot_line = $1;
- if ($hot_line eq "##")
+ $msg = "enable special treatment of the option";
+ gp_message ("debug", $subr_name, $msg);
+
+ $special_treatment = $TRUE;
+ }
+
#------------------------------------------------------------------------------
-# The line id comes after the "##" symbol and the metrics.
+# Issue a warning if the same option occcurs more often than what is supported.
#------------------------------------------------------------------------------
- {
- $line_id = $fields_in_line[$number_of_metrics+1];
+ if ($excess_occurrences)
+ {
+ $msg = "multiple occurrences of the " . $option_name .
+ " option found:";
+
+ gp_message ("debugM", $subr_name, $msg);
+
+ gp_message ("warning", $subr_name, $g_html_new_line . $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Main loop over all the occurrences of the options. This is a rather simple
+# approach since only the last value seen will be accepted.
+#
+# To assist the user with troubleshooting, the values that are ignored will be
+# checked for validity and a marker to this extent will be printed.
+#
+# NOTE:
+# If an option may have multiple meaningful occurrences, this part needs to be
+# revisited.
+#------------------------------------------------------------------------------
+ $deprecated_option_used = $FALSE;
+ for my $key (keys @option_dir)
+ {
+ $option_value = $option_dir[$key];
+ $reset_blank_value = $FALSE;
+
+#------------------------------------------------------------------------------
+# For the "onoff" options, convert a blank value to "on".
+#------------------------------------------------------------------------------
+ if (($option_value eq "on") or ($option_value eq "off"))
+ {
+ if (($option_name eq "--verbose") or ($option_name eq "--quiet"))
+ {
+ $deprecated_option_used = $TRUE;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# For the "onoff" options, convert a blank value to "on".
+#------------------------------------------------------------------------------
+ if ($special_treatment and ($option_value eq ""))
+ {
+ $option_value = "on";
+ $reset_blank_value = $TRUE;
+
+ $msg = "reset option value for $option_name from blank";
+ $msg .= " to \"on\"";
+ gp_message ("debug", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Check for the option value to be valid. It may also happen that an option
+# does not have a value, while it should have one.
+#------------------------------------------------------------------------------
+ ($valid_ref, $option_value_missing_ref) = check_and_set_user_option (
+ $internal_option_name,
+ $option_value);
+
+ $valid = ${ $valid_ref };
+ $option_value_missing = ${ $option_value_missing_ref };
+
+ $msg = "option_value = $option_value";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "after check_and_set_user_option: valid = $valid";
+ $msg .= " option_value_missing = $option_value_missing";
+ gp_message ("debug", $subr_name, $msg);
+
+#------------------------------------------------------------------------------
+# Generate warning messages, but if an option value is missing, it will also
+# be considered to be a fatal error.
+#------------------------------------------------------------------------------
+ if ($excess_occurrences)
+ {
+ if ($option_value_missing)
+ {
+ $msg = "$option_name option - missing a value";
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# A little trick to avoid user confusion. Although we have set the internal
+# value to "on", the user did not set this and so we print "" instead.
+#------------------------------------------------------------------------------
+ if ($reset_blank_value)
+ {
+ $msg = "$option_name option - value = \"\"";
+ }
+ else
+ {
+ $msg = "$option_name option - value = $option_value";
+ }
+ $msg .= ($valid) ? " (valid value)" : " (invalid value)";
+ }
+
+ gp_message ("debug", $subr_name, $msg);
+ gp_message ("warning", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Check for the last occurrence of the option to be valid. If it is not, it
+# is a fatal error.
+#------------------------------------------------------------------------------
+ if ((not $valid) && ($key == $no_of_occurrences-1))
+ {
+ if ($option_value_missing)
+ {
+ $msg = "the $option_name option requires a value";
+ }
+ else
+ {
+ $msg = "the value of $option_value for the $option_name";
+ $msg .= " option is invalid";
+ }
+ gp_message ("debug", $subr_name, $g_error_keyword . $msg);
+
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Issue a warning if the same option occcurs more often than what is supported
+# and warn the user that all but the last value will be ignored.
+#------------------------------------------------------------------------------
+ if ($excess_occurrences)
+ {
+ $msg = "all values but the last one shown above are ignored";
+
+ gp_message ("debugM", $subr_name, $msg);
+ gp_message ("warning", $subr_name, $msg);
+
+ $g_total_warning_count++;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Issue a warning if the old on/off syntax is used still.
+#------------------------------------------------------------------------------
+ if ($deprecated_option_used)
+ {
+ $msg = "<br>";
+ $msg .= "the on/off syntax for option $option_name has been";
+ $msg .= " deprecated";
+ gp_message ("warning", $subr_name, $msg);
+
+ $msg = "this option acts like a switch now";
+ gp_message ("warning", $subr_name, $msg);
+
+ $msg = "support for the old syntax may be terminated";
+ $msg .= " in a future update";
+ gp_message ("warning", $subr_name, $msg);
+
+ $msg = "please check the man page of gp-display-html";
+ $msg .= " for more details";
+ gp_message ("warning", $subr_name, $msg);
+ $g_total_warning_count++;
+ }
+
+ return (\$valid);
+
+} #-- End of subroutine extract_option_value
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub extract_source_line_number
+{
+ my $subr_name = get_my_name ();
+
+ my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_;
+
+#------------------------------------------------------------------------------
+# The regex section.
+#------------------------------------------------------------------------------
+ my $find_dot_regex = '\.';
+
+ my @fields_in_line = ();
+ my $hot_line;
+ my $line_id;
+
+#------------------------------------------------------------------------------
+# To extract the source line number, we need to distinguish whether this is
+# a line with, or without metrics.
+#------------------------------------------------------------------------------
+ @fields_in_line = split (" ", $input_line);
+ if ( $input_line =~ /$src_times_regex/ )
+ {
+ $hot_line = $1;
+ if ($hot_line eq "##")
+#------------------------------------------------------------------------------
+# The line id comes after the "##" symbol and the metrics.
+#------------------------------------------------------------------------------
+ {
+ $line_id = $fields_in_line[$number_of_metrics+1];
}
else
#------------------------------------------------------------------------------
} #-- End of subroutine extract_source_line_number
#------------------------------------------------------------------------------
-# For a give routine name and address, find the index into the
+# Finalize the settings for the special options verbose, debug, warnings and
+# quiet.
+#------------------------------------------------------------------------------
+sub finalize_special_options
+{
+ my $subr_name = get_my_name ();
+
+ my $msg;
+
+#------------------------------------------------------------------------------
+# If quiet mode has been enabled, disable verbose, warnings and debug.
+#------------------------------------------------------------------------------
+ if ($g_quiet)
+ {
+ $g_user_settings{"verbose"}{"current_value"} = "off";
+ $g_user_settings{"nowarnings"}{"current_value"} = "on";
+ $g_user_settings{"warnings"}{"current_value"} = "off";
+ $g_user_settings{"debug"}{"current_value"} = "off";
+ $g_debug = $FALSE;
+ $g_verbose = $FALSE;
+ $g_warnings = $FALSE;
+ my $debug_off = "off";
+ my $ignore_value = set_debug_size (\$debug_off);
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# Disable output buffering if verbose, debug, and/or warnings are enabled.
+#------------------------------------------------------------------------------
+ if ($g_verbose or $g_debug or $g_warnings)
+ {
+ STDOUT->autoflush (1);
+
+ $msg = "enabled autoflush for STDOUT";
+ gp_message ("debug", $subr_name, $msg);
+ }
+#------------------------------------------------------------------------------
+# If verbose and/or debug have been enabled, print a message.
+#------------------------------------------------------------------------------
+## gp_message ("verbose", $subr_name, "verbose mode has been enabled");
+## gp_message ("debug", $subr_name, "debug " . $g_debug_size_value . " mode has been enabled");
+ }
+
+ return (0);
+
+} #-- End of subroutine finalize_special_options
+
+#------------------------------------------------------------------------------
+# For a give routine name and address, find the index into the
# function_info array
#------------------------------------------------------------------------------
sub find_index_in_function_info
$addr_offset = $function_info[$ref_index]{"addressobjtext"};
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
-
+
$addr_offset =~ s/^@\d+://;
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
if ($addr_offset eq $current_address)
}
}
- return (\$error_occurred, \$return_value);
+ return (\$error_occurred, \$gp_path, \$return_value);
} #-- End of subroutine find_path_to_gp_display_text
$start_word = $space_position;
$end_word = $space - 1;
$space_position = $space;
- my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
+ my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword");
push (@word_delimiters, [$start_word, $end_word]);
}
elsif ( ($space == $space_position) and ($space < length ($input_line) - 1))
{
$space = $space + 1;
- $space_position = $space;
+ $space_position = $space;
}
else
{
$finished = $TRUE;
$start_word = $space_position;
$end_word = length ($input_line) - 1;
- my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
+ my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
push (@word_delimiters, [$start_word, $end_word]);
if ($keyword =~ /\s+/)
{
# TBD
#------------------------------------------------------------------------------
sub function_info
-{
+{
my $subr_name = get_my_name ();
my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_;
my $full_address_field;
my $FUNC_FILE_NO_PC;
- my $off_with_the_PC;
+ my $off_with_the_PC;
my $blanks;
my $lblanks;
#------------------------------------------------------------------------------
my $length_of_string = length ($outputdir);
- if (rindex ($outputdir, "/") != $length_of_string-1)
+ if (rindex ($outputdir, "/") != $length_of_string-1)
{
$outputdir .= "/";
}
$FUNC_FILE_NO_PC = $outputdir."calls";
$is_calls = $TRUE;
$metric_ok = $FALSE;
- }
+ }
elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func")
{
$FUNC_FILE_NO_PC = $outputdir."calltree";
$metric_ok = $FALSE;
- }
+ }
elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func")
{
$FUNC_FILE_NO_PC = $outputdir."functions.func";
# er_print * before PC for calls ! 101315
#------------------------------------------------------------------------------
$line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)";
- }
- else
+ }
+ else
{
$line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)";
}
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5");
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6");
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7");
- }
- else
+ }
+ else
{
$segment = $2;
$offset = $4;
{
$metric_value = $1; # whatever
$routine = $2;
- }
- else
+ }
+ else
{
$routine = $1;
}
for $vdso_key (keys %LINUX_vDSO)
{
if ($routine eq $LINUX_vDSO{$vdso_key})
- {
+ {
#------------------------------------------------------------------------------
# presume no duplicates - at least can check offset
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# the real segment
#------------------------------------------------------------------------------
- $segment = $1;
+ $segment = $1;
gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE");
$PC_Address = $segment.":".$offset; # PC Addr.
gp_message ("debugXL", $subr_name, "vdso line ->$line");
}
}
}
- }
- else
+ }
+ else
{
gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE");
}
}
gp_message ("debugXL", $subr_name, "vdso line ->$line");
if (substr ($line,$lblanks+$lvdso_key,1) eq " ")
- {
+ {
#------------------------------------------------------------------------------
# O.K. no field abuttal
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line");
- }
- else
+ }
+ else
{
gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line");
$line = $blanks.$vdso_key." ".$rest;
}
$not_printed = $FALSE;
}
- }
- else
+ }
+ else
{
if (!$pc_len)
{
{
$pc_len = length ($1); # say 15
print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
- }
- else
+ }
+ else
{
print FUNC_FILE_NO_PC "$line\n";
}
- }
- else
+ }
+ else
{
if ($pc_len)
{
my $strlen = length ($line);
- if ($strlen > 0 )
+ if ($strlen > 0 )
{
print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
}
{
$metric_value = $1; # whatever
$routine = $2;
- }
- else
+ }
+ else
{
$routine = $1;
}
if (not exists ($functions_per_metric_indexes{$routine}))
{
$functions_per_metric_indexes{$routine} = [$index_val];
- }
- else
+ }
+ else
{
push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list
}
{
$functions_per_metric_first_index{$routine}{$PC_Address} = $index_val;
$u++; #$RI
- }
- else
+ }
+ else
{
if (!($metric eq "calls" || $metric eq "calltree"))
{
gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address");
}
- }
+ }
$index_val++;
gp_message ("debugXL", $subr_name, "updated index_val = $index_val");
$n++;
next;
- }
- else
+ }
+ else
{
if ($n && length ($line))
{
{
my $subr_name = get_my_name ();
- my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref,
- $function_address_info_ref, $addressobjtextm_ref,
+ my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref,
+ $function_address_info_ref, $addressobjtextm_ref,
$input_string_ref) = @_;
my $number_of_metrics = ${ $number_of_metrics_ref };
my $full_hex_address;
my $hex_address;
- my $file_title;
- my $page_title;
- my $size_text;
- my $position_text;
+ my $file_title;
+ my $page_title;
+ my $size_text;
+ my $position_text;
my @html_metric_sort_header = ();
my $html_header;
my $html_title_header;
my $html_acknowledgement;
my $html_end;
my $html_line;
-
+
my $marker_target_function;
my $max_metrics_length = 0;
- my $metrics_length;
- my $modified_line;
+ my $metrics_length;
+ my $modified_line;
my $name_regex;
my $no_of_fields;
my $routine;
my $routine_length;
- my $string_length;
- my $top_header;
+ my $string_length;
+ my $top_header;
my $total_header_lines;
my $word_index_values_ref;
my $infile;
gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile");
- open (CALLER_CALLEE_IN, "<", $infile)
+ open (CALLER_CALLEE_IN, "<", $infile)
or die ("unable to open caller file $infile for reading - '$!'");
gp_message ("debug", $subr_name, "opened file $infile for reading");
$html_home = ${ generate_home_link ("right") };
$page_title = "Caller Callee View";
- $size_text = "h2";
+ $size_text = "h2";
$position_text = "center";
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
-
+
#------------------------------------------------------------------------------
# Read all of the file into array with the name caller_callee_data.
#------------------------------------------------------------------------------
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
# Functions sorted by metric: Exclusive Total CPU Time
# Callers and callees sorted by metric: Attributed Total CPU Time
-#
+#
# PC Addr. Name Attr. Attr. CPU Attr. Attr.
# Total Cycles Instructions Last-Level
# CPU sec. sec. Executed Cache Misses
# 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250
# 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045
# 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205
-#
+#
# PC Addr. Name Attr. Attr. CPU Attr. Attr.
# Total Cycles Instructions Last-Level
# CPU sec. sec. Executed Cache Misses
#------------------------------------------------------------------------------
# Scan the input file. The first lines are assumed to be part of the header,
# so we store those. The diagnostic lines that echo some settings are also
-# stored, but currently not used.
+# stored, but currently not used.
#------------------------------------------------------------------------------
my $scan_header = $FALSE;
my $scan_caller_callee_data = $FALSE;
my $get_addr_offset_regex = '^@\d+:';
#------------------------------------------------------------------------------
-# Get the length of the first metric field across all lines. This value is
+# Get the length of the first metric field across all lines. This value is
# used to pad the first metric with spaces and get the alignment right.
#
# Scan the input data and find the line(s) with metric values. A complication
# is that a function name may consists of more than one field.
#
# Note. This part could be used to parse the other elements of the input file,
-# but that makes the loop very complicated. Instead, we re-scan the data
+# but that makes the loop very complicated. Instead, we re-scan the data
# below and process each block separately.
#
# Since this data is all in memory and relatively small, the performance should
{
if (defined ($1) and defined ($2) and defined ($3))
#------------------------------------------------------------------------------
-# This is a line of interest, since it has the address, the function name and
+# This is a line of interest, since it has the address, the function name and
# the values for the metrics. Examples of valid lines are:
#
# 2:0x00005028 *xfree_large 0. 0
# 12:0x0004c2b0 munmap 0.143 6402086
-# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0
+# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0
#
# The function name marked with a * is the current target.
#------------------------------------------------------------------------------
if ($full_hex_address =~ /$get_hex_address_regex/)
{
$hex_address = "0x" . $2;
- push (@hex_addresses, $hex_address);
+ push (@hex_addresses, $hex_address);
gp_message ("debugXL", $subr_name, "pushed $hex_address");
}
else
}
if ($marker eq "*")
{
- push (@special_marker, "*");
+ push (@special_marker, "*");
}
else
{
- push (@special_marker, "X");
+ push (@special_marker, "X");
}
}
else
gp_message ("debugXL", $subr_name, $txt);
#------------------------------------------------------------------------------
-# Generate the regex for the metrics.
+# Generate the regex for the metrics.
#
# TBD: This should be an attribute of the function and be done once only.
#------------------------------------------------------------------------------
" its metrics = " . $its_metrics;
gp_message ("debugXL", $subr_name, $msg);
- push (@the_function_name, $func_name);
- push (@the_metrics, $its_metrics);
+ push (@the_function_name, $func_name);
+ push (@the_metrics, $its_metrics);
}
else
{
gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block");
push (@function_blocks, $data_function_block);
- my ($html_block_prologue_ref, $html_code_function_block_ref) =
+ my ($html_block_prologue_ref, $html_code_function_block_ref) =
generate_html_function_blocks (
\$index_start,
\$index_end,
$no_of_fields = $#fields + 1;
$elements_in_name = $no_of_fields - $number_of_metrics - 1;
-
+
#------------------------------------------------------------------------------
# TBD: Too restrictive.
# CHECK CODE IN GENERATE_CALLER_CALLEE
#------------------------------------------------------------------------------
- if ($elements_in_name == 1)
+ if ($elements_in_name == 1)
{
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)';
}
- elsif ($elements_in_name == 2)
+ elsif ($elements_in_name == 2)
{
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)';
}
$full_hex_address = $1;
$marker_target_function = $2;
$routine = $3;
- if ($elements_in_name == 1)
+ if ($elements_in_name == 1)
{
$all_metrics = $4;
}
- elsif ($elements_in_name == 2)
+ elsif ($elements_in_name == 2)
{
$all_metrics = $6;
}
$hex_address = "0x" . $2;
}
push (@marker, $marker_target_function);
- push (@address_field, $hex_address);
+ push (@address_field, $hex_address);
$modified_line = $all_metrics . " " . $routine;
push (@metric_values, $all_metrics);
gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line");
my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
-
+
$addr_offset =~ s/$get_addr_offset_regex//;
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
if ($addr_offset eq $current_address)
print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee;
print CALLER_CALLEE_OUT "</pre>\n";
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Get the acknowledgement, return to main link, and final html statements.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$html_home = ${ generate_home_link ("left") };
$html_acknowledgement = ${ create_html_credits () };
$html_end = ${ terminate_html_document () };
{
my $subr_name = get_my_name ();
- my ($target_function_ref, $number_of_metrics_ref, $function_info_ref,
- $function_address_and_index_ref, $outputdir_ref, $func_ref,
+ my ($target_function_ref, $number_of_metrics_ref, $function_info_ref,
+ $function_address_and_index_ref, $outputdir_ref, $func_ref,
$source_line_ref, $metric_ref, $addressobj_index_ref) = @_;
my $target_function = ${ $target_function_ref };
my $hex_instruction_end;
my @colour_line = ();
- my $hot_line;
- my $metric_values;
+ my $hot_line;
+ my $metric_values;
my $src_line;
- my $dec_instr_address;
+ my $dec_instr_address;
my $instruction;
my $operands;
-
+
my $html_new_line = "<br>";
my $add_new_line_before;
- my $add_new_line_after;
- my $address_key;
+ my $add_new_line_after;
+ my $address_key;
my $boldface;
my $file;
my $filename = $func;
my $func_name;
- my $orig_hex_instr_address;
- my $hex_instr_address;
+ my $orig_hex_instr_address;
+ my $hex_instr_address;
my $index_string;
my $input_metric;
my $linenumber;
my $name;
- my $last_address;
- my $last_address_in_hex;
+ my $last_address;
+ my $last_address_in_hex;
- my $file_title;
+ my $file_title;
my $html_header;
my $html_home;
my $html_end;
-
- my $branch_regex = $g_arch_specific_settings{"regex"};
+
+ my $branch_regex = $g_arch_specific_settings{"regex"};
my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
my $decimal_separator = $g_locale_settings{"decimal_separator"};
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
my $linksubexp = $g_arch_specific_settings{"linksubexp"};
my $subexp = $g_arch_specific_settings{"subexp"};
- my $is_empty;
+ my $file_is_empty;
my %branch_target = ();
my %branch_target_no_ref = ();
my $extended_branch_target_ref;
my $branch_target_no_ref_ref;
- my $branch_address;
- my $dec_branch_address;
+ my $branch_address;
+ my $dec_branch_address;
my $found_it;
my $found_it_ref;
my $func_name_in_dis_file;
my $hex_branch_target;
- my $instruction_address;
- my $instruction_offset;
+ my $instruction_address;
+ my $instruction_offset;
my $link;
my $modified_line;
my $raw_hex_branch_target;
push (@modified_html, $html_header);
push (@modified_html, $html_home);
push (@modified_html, "<pre>");
-
+
#------------------------------------------------------------------------------
# Open the input and output files.
#------------------------------------------------------------------------------
- open (INPUT_DISASSEMBLY, "<", $filename)
+ open (INPUT_DISASSEMBLY, "<", $filename)
or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
gp_message ("debug", $subr_name , "opened file $filename for reading");
#------------------------------------------------------------------------------
# Check if the file is empty
#------------------------------------------------------------------------------
- $is_empty = is_file_empty ($filename);
- if ($is_empty)
+ $file_is_empty = is_file_empty ($filename);
+ if ($file_is_empty)
{
#------------------------------------------------------------------------------
@metrics = split (/$white_space_regex/ ,$1);
$src_line_no = $2;
}
- else
+ else
{
my $msg = "$input_line has an unexpected format";
gp_message ("assertion", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# Compute the maximum length of the first metric and pad the field from the
+# Compute the maximum length of the first metric and pad the field from the
# left later on. The fractional part is ignored.
#------------------------------------------------------------------------------
my $first_metric = $metrics[0];
- my $new_length;
+ my $new_length;
if ($first_metric =~ /$first_integer_regex/)
{
$new_length = length ($first_metric);
#------------------------------------------------------------------------------
{
$source_line[$line_no] = $src_line_no;
- my $msg;
- $msg = "found an instruction with a source line ref: ";
- $msg .= "source_line[$line_no] = $source_line[$line_no]";
+ my $msg;
+ $msg = "found an instruction with a source line ref:";
+ $msg .= " source_line[$line_no] = $source_line[$line_no]";
gp_message ("debugXL", $subr_name, $msg);
}
-
+
#------------------------------------------------------------------------------
-# Check for function calls. If found, get the address offset from $4 and
+# Check for function calls. If found, get the address offset from $4 and
# compute the target address.
#------------------------------------------------------------------------------
- ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) =
+ ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) =
check_and_proc_dis_func_call (
\$input_line,
- \$line_no,
+ \$line_no,
\%branch_target,
\%extended_branch_target);
$found_it = ${ $found_it_ref };
($found_it_ref, $branch_target_ref, $extended_branch_target_ref,
$branch_target_no_ref_ref) = check_and_proc_dis_branches (
\$input_line,
- \$line_no,
+ \$line_no,
\%branch_target,
\%extended_branch_target,
\%branch_target_no_ref);
# In both cases, the first line after the header has whitespace. This is
# followed by:
#
-# - A source line file has "<line_no>."
+# - A source line file has "<line_no>."
# - A dissasembly file has "<Function:"
#
# These are the characteristics we use below.
last;
}
push (@modified_html, "<i>" . $input_line . "</i>");
-
}
my $line_index = scalar (@modified_html);
gp_message ("debugXL", $subr_name, "final line_index = $line_index");
}
for my $row (keys @hot_program_counters)
{
- my $msg = "$filename row[" . $row . "] = ";
+ my $msg = "$filename row[" . $row . "] =";
for my $col (keys @{$hot_program_counters[$row]})
{
- $msg .= "$hot_program_counters[$row][$col] ";
- $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col];
+ $msg .= " $hot_program_counters[$row][$col]";
+ $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col];
}
gp_message ("debugXL", $subr_name, "hot PC = $msg");
}
for my $row (keys @transposed_hot_pc)
{
- my $msg = "$filename row[" . $row . "] = ";
+ my $msg = "$filename row[" . $row . "] =";
for my $col (keys @{$transposed_hot_pc[$row]})
{
- $msg .= "$transposed_hot_pc[$row][$col] ";
+ $msg .= " $transposed_hot_pc[$row][$col]";
}
gp_message ("debugXL", $subr_name, "$filename transposed = $msg");
}
my $max_val = 0;
for my $col (0 .. $#{$transposed_hot_pc[$row]})
{
- $max_val = max ($transposed_hot_pc[$row][$col], $max_val);;
+ $max_val = max ($transposed_hot_pc[$row][$col], $max_val);
}
if ($max_val =~ /$integer_regex/)
{
if (defined ($dec_instruction_start))
{
- if ($dec_instr_address < $dec_instruction_start)
+ if ($dec_instr_address < $dec_instruction_start)
{
$dec_instruction_start = $dec_instr_address;
}
}
if (defined ($dec_instruction_end))
{
- if ($dec_instr_address > $dec_instruction_end)
+ if ($dec_instr_address > $dec_instruction_end)
{
$dec_instruction_end = $dec_instr_address;
}
#------------------------------------------------------------------------------
# Pad the line with the metrics to ensure correct alignment.
#------------------------------------------------------------------------------
- my $the_length;
+ my $the_length;
my @split_metrics = split (" ", $metric_values);
my $first_metric = $split_metrics[0];
## if ($first_metric =~ /^\d+$/)
#------------------------------------------------------------------------------
# Since the instruction address variable may change and because we need the
-# original address without html controls, we use a new variable for the
+# original address without html controls, we use a new variable for the
# (potentially) modified address.
#------------------------------------------------------------------------------
$hex_instr_address = $orig_hex_instr_address;
# Mark control flow instructions. Several cases need to be distinguished.
#
# In all cases we give the instruction a specific color, mark it boldface
-# and add a new-line after the instruction
+# and add a new-line after the instruction
#------------------------------------------------------------------------------
if ( ($instruction =~ /$control_flow_1_regex/) or
($instruction =~ /$control_flow_2_regex/) or
}
## if (exists ($inverse_branch_target{$hex_instr_address}) or
## exists ($branch_target_no_ref{$hex_instr_address}))
- if (exists ($inverse_branch_target{$hex_instr_address}))
+ if (exists ($inverse_branch_target{$hex_instr_address}))
#------------------------------------------------------------------------------
# This is a target address and we need to define the instruction address to be
# a label.
gp_message ("debugXL", $subr_name, "final modified_line = $modified_line");
#------------------------------------------------------------------------------
-# This is a control flow instruction, but it is the last one and we do not
+# This is a control flow instruction, but it is the last one and we do not
# want to add a newline.
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html");
gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after");
gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before");
-
+
if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) )
{
$add_new_line_after = $FALSE;
#------------------------------------------------------------------------------
{
$modified_line = set_background_color_string (
- $modified_line,
+ $modified_line,
$g_html_color_scheme{"background_color_hot"});
}
#------------------------------------------------------------------------------
my @current_metrics = split (" ", $metric_values);
for my $metric (0 .. $#current_metrics)
{
- my $current_value;
+ my $current_value;
my $max_value;
$current_value = $current_metrics[$metric];
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line");
$modified_line = set_background_color_string (
- $modified_line,
+ $modified_line,
$g_html_color_scheme{"background_color_lukewarm"});
last;
}
my $spaces = $1;
my $boldface = $TRUE;
gp_message ("debugXL", $subr_name, "function_name = $2");
- my $function_line = "<Function: " . $func_name_in_dis_file . ">";
+ my $function_line = "<Function: " . $func_name_in_dis_file . ">";
-##### HACK
+##### HACK
if ($func_name_in_dis_file eq $target_function)
{
my $color_function_name = color_string (
- $function_line,
- $boldface,
+ $function_line,
+ $boldface,
$g_html_color_scheme{"target_function_name"});
my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>";
$html_name = $label . $spaces . "<i>" . $color_function_name . "</i>";
else
{
my $color_function_name = color_string (
- $function_line,
- $boldface,
+ $function_line,
+ $boldface,
$g_html_color_scheme{"non_target_function_name"});
$html_name = "<i>" . $spaces . $color_function_name . "</i>";
}
#
# TBD: The same is done in process_source but should be done only once.
#------------------------------------------------------------------------------
- if ($hp_value > 0)
+ if ($hp_value > 0)
{
my $rounded_percentage = sprintf ("%.1f", $hp_value);
- $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
+ $threshold_line = "<i>The setting for the highlight percentage";
+ $threshold_line .= " (--highlight-percentage) option:";
+ $threshold_line .= " " . $rounded_percentage . " (%)</i>";
}
else
{
- $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
+ $threshold_line = "<i>The highlight percentage feature has not been";
+ $threshold_line .= " enabled</i>";
}
$html_home = ${ generate_home_link ("left") };
{
my $subr_name = get_my_name ();
- my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string,
+ my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string,
$sort_fields_ref) = @_;
my @exp_dir_list = @{ $exp_dir_list_ref };
gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files");
- open (SCRIPT_PC, ">", $script_file_PC)
+ open (SCRIPT_PC, ">", $script_file_PC)
or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'");
gp_message ("debug", $subr_name, "opened file $script_file_PC for writing");
#------------------------------------------------------------------------------
# Else the output from the next line goes to last sort.func
#------------------------------------------------------------------------------
- print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n";
- print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n";
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n";
print SCRIPT_PC "# metrics $script_pc_metrics\n";
print SCRIPT_PC "metrics $script_pc_metrics\n";
#------------------------------------------------------------------------------
# Not really sorted
#------------------------------------------------------------------------------
- print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n";
- print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n";
+ print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n";
print SCRIPT_PC "# functions\n";
print SCRIPT_PC "functions\n";
- print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n";
- print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n";
+ print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n";
+ print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n";
print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
print SCRIPT_PC "metrics address:name:$summary_metrics\n";
print SCRIPT_PC "# sort $first_metric\n";
#------------------------------------------------------------------------------
# Else the output from the next line goes to last sort.func
#------------------------------------------------------------------------------
- print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n";
- print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n";
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n";
print SCRIPT_PC "# metrics $script_pc_metrics\n";
print SCRIPT_PC "metrics $script_pc_metrics\n";
print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n";
#------------------------------------------------------------------------------
# Else the output from the next line goes to last sort.func
#------------------------------------------------------------------------------
- print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n";
- print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n";
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n";
$script_pc_metrics = "address:$call_metrics";
print SCRIPT_PC "# metrics $script_pc_metrics\n";
print SCRIPT_PC "metrics $script_pc_metrics\n";
#------------------------------------------------------------------------------
# Not really sorted
#------------------------------------------------------------------------------
- print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n";
- print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n";
+ print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n";
#------------------------------------------------------------------------------
# Get caller-callee list
if ($error_code != 0)
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
- gp_message ("abort", "execution terminated");
+ gp_message ("abort", $subr_name, "execution terminated");
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Parse the full function view and store the data.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my @input_data = ();
my $empty_line_regex = '^\s*$';
-
+
## my $full_function_view = $outputdir . "functions.full";
open (ALL_FUNC_DATA, "<", $full_function_view)
for (my $line = 0; $line <= $#input_data; $line++)
{
my $input_line = $input_data[$line];
-
+
# if ($input_line =~ /^<Total>\s+.*/)
if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/)
{
gp_message ("debugXL", $subr_name, "$line: $input_data[$line]");
push (@g_full_function_view_table, $input_data[$line]);
-
+
my $hex_address;
my $full_hex_address = $1;
my $routine = $2;
{
my $subr_name = get_my_name ();
- my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref,
- $function_info_ref, $function_view_structure_ref, $function_address_info_ref,
+ my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref,
+ $function_info_ref, $function_view_structure_ref, $function_address_info_ref,
$sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_;
my $directory_name = ${ $directory_name_ref };
my %addressobjtextm = %{ $addressobjtextm_ref };
my @abs_path_exp_dirs = ();
- my @experiment_directories;
+ my @experiment_directories;
- my $target_function;
+ my $target_function;
my $html_line;
my $ftag;
- my $routine_length;
+ my $routine_length;
my %html_source_functions = ();
- my $href_link;
+ my $href_link;
my $infile;
my $input_experiments;
- my $keep_value;
- my $loadobj;
- my $address_field;
- my $address_offset;
+ my $keep_value;
+ my $loadobj;
+ my $address_field;
+ my $address_offset;
my $msg;
- my $exe;
- my $extra_field;
+ my $exe;
+ my $extra_field;
my $new_target_function;
- my $file_title;
- my $html_output_file;
- my $html_function_view;
- my $overview_file;
- my $exp_name;
- my $exp_type;
+ my $file_title;
+ my $html_output_file;
+ my $html_function_view;
+ my $overview_file;
+ my $exp_name;
+ my $exp_type;
my $html_header;
- my $routine;
- my $length_header;
+ my $routine;
+ my $length_header;
my $length_metrics;
- my $full_index_line;
- my $acknowledgement;
+ my $full_index_line;
+ my $acknowledgement;
my @full_function_view_line = ();
my $spaces;
- my $size_text;
- my $position_text;
- my $html_first_metric_file;
+ my $size_text;
+ my $position_text;
+ my $html_first_metric_file;
my $html_new_line = "<br>";
- my $html_acknowledgement;
+ my $html_acknowledgement;
my $html_end;
- my $html_home;
- my $page_title;
- my $html_title_header;
+ my $html_home;
+ my $page_title;
+ my $html_title_header;
my $outputdir = append_forward_slash ($directory_name);
my $LANG = $g_locale_settings{"LANG"};
gp_message ("assertion", $subr_name, $msg);
}
- $html_source_functions{$target_function} = $function_info[$i]{"html function block"};
+ $html_source_functions{$target_function} = $function_info[$i]{"html function block"};
}
for my $i (sort keys %html_source_functions)
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
# Functions sorted by metric: Exclusive Total CPU Time
-#
+#
# PC Addr. Name Excl. Excl. CPU Excl. Excl.
# Total Cycles Instructions Last-Level
# CPU sec. sec. Executed Cache Misses
}
#------------------------------------------------------------------------------
# The default function view is based upon the first metric in the list. We use
-# this file in the index.html file.
+# this file in the index.html file.
#------------------------------------------------------------------------------
if ($metric eq $g_first_metric)
{
$html_output_file = $outputdir . $html_function_view;
- open (FUNCTION_VIEW, ">", $html_output_file)
+ open (FUNCTION_VIEW, ">", $html_output_file)
or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
$html_header = ${ create_html_header (\$file_title) };
$page_title = "Function View";
- $size_text = "h2";
+ $size_text = "h2";
$position_text = "center";
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
print FUNCTION_VIEW $html_new_line . "\n";
my $function_view_structure_ref = process_function_overview (
- \$metric,
- \$exp_type,
- \$summary_metrics,
- \$number_of_metrics,
- \@function_info,
- \%function_view_structure,
+ \$metric,
+ \$exp_type,
+ \$summary_metrics,
+ \$number_of_metrics,
+ \@function_info,
+ \%function_view_structure,
\$overview_file);
my %function_view_structure = %{ $function_view_structure_ref };
# Core part: extract the true function name and find the html code for it.
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "the final table");
-
+
print FUNCTION_VIEW "<pre>\n";
print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} };
- my $max_length_header = $function_view_structure{"max header length"};
+ my $max_length_header = $function_view_structure{"max header length"};
my $max_length_metrics = $function_view_structure{"max metrics length"};
#------------------------------------------------------------------------------
my $func_header = $spaces . $function_view_structure{"table name"};
gp_message ("debugXL", $subr_name, "func_header = " . $func_header);
-
- print FUNCTION_VIEW $spaces . "<b>" .
- $function_view_structure{"table name"} .
+ print FUNCTION_VIEW $spaces . "<b>" .
+ $function_view_structure{"table name"} .
"</b>" . $html_new_line . "\n";
#------------------------------------------------------------------------------
print FUNCTION_VIEW "$_\n" for @full_function_view_line;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Clear the array before filling it up again.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
@full_function_view_line = ();
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Get the acknowledgement, return to main link, and final html statements.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$html_home = ${ generate_home_link ("left") };
$html_acknowledgement = ${ create_html_credits () };
$html_end = ${ terminate_html_document () };
close (FUNCTION_VIEW);
}
- return (\$html_first_metric_file);
+ return (\$html_first_metric_file);
} #-- End of subroutine generate_function_view
my ($which_side) = @_;
- my $html_home_line;
+ my $html_home_line;
if (($which_side ne "left") and ($which_side ne "right"))
{
}
$html_home_line .= "<div class=\"" . $which_side . "\">";
- $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"};
- $html_home_line .= ".html' style='background-color:";
+ $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"};
+ $html_home_line .= ".html' style='background-color:";
$html_home_line .= $g_html_color_scheme{"index"};
$html_home_line .= "'><b>Return to main view</b></a>";
$html_home_line .= "</div>";
$length_first_metric_ref,
$special_marker_ref,
$the_function_name_ref,
- $separator_ref,
- $number_of_metrics_ref,
- $data_function_block_ref,
- $function_info_ref,
- $function_view_structure_ref) = @_;
+ $separator_ref,
+ $number_of_metrics_ref,
+ $data_function_block_ref,
+ $function_info_ref,
+ $function_view_structure_ref) = @_;
my $index_start = ${ $index_start_ref };
my $index_end = ${ $index_end_ref };
my @function_info = @{ $function_info_ref };
my %function_view_structure = %{ $function_view_structure_ref };
- my $decimal_separator = $g_locale_settings{"decimal_separator"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
my @html_block_prologue = ();
my @html_code_function_block = ();
my @split_number = ();
my @function_tags = ();
- my $all_metrics;
+ my $all_metrics;
my $current_function_name;
my $no_of_fields;
my $name_regex;
my $full_hex_address;
my $hex_address;
- my $target_function;
- my $marker_function;
- my $routine;
- my $routine_length;
- my $metrics_length;
+ my $target_function;
+ my $marker_function;
+ my $routine;
+ my $routine_length;
+ my $metrics_length;
my $max_metrics_length = 0;
my $modified_line;
- my $string_length;
- my $addr_offset;
- my $current_address;
+ my $string_length;
+ my $addr_offset;
+ my $current_address;
my $found_a_match;
my $ref_index;
my $alt_name;
- my $length_first_field;
+ my $length_first_field;
my $gap;
- my $ipad;
- my $html_line;
- my $target_tag;
- my $tag_for_header;
- my $href_file;
- my $found_alt_name;
+ my $ipad;
+ my $html_line;
+ my $target_tag;
+ my $tag_for_header;
+ my $href_file;
+ my $found_alt_name;
my $name_in_header;
my $create_hyperlinks;
{
my $decimal_point = $decimal_separator;
$decimal_point =~ s/\\//;
- my $txt = "input_line = $input_line = ended with 0";
+ my $txt = "input_line = $input_line = ended with 0";
$txt .= $decimal_point;
gp_message ("debugXL", $subr_name, $txt);
$max_metrics_length = max ($max_metrics_length, $metrics_length);
push (@marker, $marker_function);
- push (@address_field, $hex_address);
+ push (@address_field, $hex_address);
push (@metric_values, $all_metrics);
push (@function_names, $routine);
my $index_into_function_info_ref = get_index_function_info (
- \$routine,
- \$hex_addresses[$i],
+ \$routine,
+ \$hex_addresses[$i],
$function_info_ref);
- my $index_into_function_info = ${ $index_into_function_info_ref };
+ my $index_into_function_info = ${ $index_into_function_info_ref };
$target_tag = $function_info[$index_into_function_info]{"tag_id"};
$alt_name = $function_info[$index_into_function_info]{"alt_name"};
if ($marker[$i] eq "*")
{
- $html_line = "<br>" . $html_line;
+ $html_line = "<br>" . $html_line;
}
elsif (($marker[$i] ne "*") and ($i == 0))
{
- $html_line = "<br>" . $html_line;
+ $html_line = "<br>" . $html_line;
}
gp_message ("debugXL", $subr_name, "html_line = $html_line");
$routine = $function_names[$i];
$current_address = $address_field[$i];
- my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info);
+ my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info);
my $target_index = ${ $target_index_ref };
gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index");
# TBD Do this once for each function and store the result. This is a saving
# because functions may and typically will appear more than once.
#------------------------------------------------------------------------------
- my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"};
+ my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"};
#------------------------------------------------------------------------------
# Add the links to the line. Make sure there is at least one space.
$html_line .= $function_info[$target_index]{"href_disassembly"};
}
- push (@html_code_function_block, $html_line);
+ push (@html_code_function_block, $html_line);
}
for my $lines (0 .. $#html_code_function_block)
gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]);
}
- return (\@html_block_prologue, \@html_code_function_block);
+ return (\@html_block_prologue, \@html_code_function_block);
} #-- End of subroutine generate_html_function_blocks
#------------------------------------------------------------------------------
-# Generate the index.html file.
-#------------------------------------------------------------------------------
-sub generate_index
-{
- my $subr_name = get_my_name ();
-
- my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref,
- $number_of_metrics_ref, $function_info_ref, $function_address_info_ref,
- $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref,
- $metric_description_reversed_ref, $number_of_warnings_ref,
- $table_execution_stats_ref) = @_;
-
- my $outputdir = ${ $outputdir_ref };
- my $html_first_metric_file = ${ $html_first_metric_file_ref };
- my $summary_metrics = ${ $summary_metrics_ref };
- my $number_of_metrics = ${ $number_of_metrics_ref };
- my @function_info = @{ $function_info_ref };
- my %function_address_info = %{ $function_address_info_ref };
- my @sort_fields = @{ $sort_fields_ref };
- my @exp_dir_list = @{ $exp_dir_list_ref };
- my %addressobjtextm = %{ $addressobjtextm_ref };
- my %metric_description_reversed = %{ $metric_description_reversed_ref };
- my $number_of_warnings = ${ $number_of_warnings_ref };
- my @table_execution_stats = @{ $table_execution_stats_ref };
-
- my @file_contents = ();
-
- my $acknowledgement;
- my @abs_path_exp_dirs = ();
- my $input_experiments;
- my $target_function;
- my $html_line;
- my $ftag;
- my $max_length = 0;
- my %html_source_functions = ();
- my $html_header;
- my @experiment_directories = ();
- my $html_acknowledgement;
- my $html_file_title;
- my $html_output_file;
- my $html_function_view;
- my $html_caller_callee_view;
- my $html_experiment_info;
- my $html_warnings_page;
- my $href_link;
- my $file_title;
- my $html_gprofng;
- my $html_end;
- my $max_length_metrics;
- my $page_title;
- my $size_text;
- my $position_text;
-
- my $ln;
- my $base;
- my $base_index_page;
- my $infile;
- my $outfile;
- my $rec;
- my $skip;
- my $callsize;
- my $dest;
- my $final_string;
- my @headers;
- my $header;
- my $sort_index;
- my $pc_address;
- my $anchor;
- my $directory_name;
- my $f2;
- my $f3;
- my $file;
- my $sline;
- my $src;
- my $srcfile_name;
- my $tmp1;
- my $tmp2;
- my $fullsize;
- my $regf2;
- my $trimsize;
- my $EIL;
- my $EEIL;
- my $AOBJ;
- my $RI;
- my $HDR;
- my $CALLER_CALLEE;
- my $NAME;
- my $SRC;
- my $TRIMMED;
-
-#------------------------------------------------------------------------------
-# Add a forward slash to make it easier when creating file names.
-#------------------------------------------------------------------------------
- $outputdir = append_forward_slash ($outputdir);
- gp_message ("debug", $subr_name, "outputdir = $outputdir");
-
- my $LANG = $g_locale_settings{"LANG"};
- my $decimal_separator = $g_locale_settings{"decimal_separator"};
-
- $input_experiments = join (", ", @exp_dir_list);
-
- for my $i (0 .. $#exp_dir_list)
- {
- my $dir = get_basename ($exp_dir_list[$i]);
- push @abs_path_exp_dirs, $dir;
- }
- $input_experiments = join (", ", @abs_path_exp_dirs);
-
- gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
-
-#------------------------------------------------------------------------------
-# TBD: Pass in the values for $expr_name and $cmd
-#------------------------------------------------------------------------------
- $html_file_title = "Main index page";
-
- @experiment_directories = split (",", $input_experiments);
- $html_acknowledgement = ${ create_html_credits () };
-
- $html_end = ${ terminate_html_document () };
-
- $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html";
-
- open (INDEX, ">", $html_output_file)
- or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
- gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
-
- $page_title = "GPROFNG Performance Analysis";
- $size_text = "h1";
- $position_text = "center";
- $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
-
- $html_header = ${ create_html_header (\$html_file_title) };
-
- print INDEX $html_header;
- print INDEX $html_gprofng;
- print INDEX "$_" for @g_html_experiment_stats;
- print INDEX "$_" for @table_execution_stats;
-
- $html_experiment_info = "<a href=\'";
- $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html";
- $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n";
-
- $html_warnings_page = "<a href=\'";
- $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html";
- $html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n";
-
- $html_function_view = "<a href=\'";
- $html_function_view .= $html_first_metric_file;
- $html_function_view .= "\'><h3>Function View</h3></a>\n";
-
- $html_caller_callee_view = "<a href=\'";
- $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html";
- $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n";
-
- print INDEX "<br>\n";
-## print INDEX "<b>\n";
- print INDEX $html_experiment_info;
- print INDEX $html_warnings_page;;
-## print INDEX "<br>\n";
-## print INDEX "<br>\n";
- print INDEX $html_function_view;
-## print INDEX "<br>\n";
-## print INDEX "<br>\n";
- print INDEX $html_caller_callee_view;
-## print INDEX "</b>\n";
-## print INDEX "<br>\n";
-## print INDEX "<br>\n";
-
- print INDEX $html_acknowledgement;
- print INDEX $html_end;
-
- close (INDEX);
-
- gp_message ("debug", $subr_name, "closed file $html_output_file");
-
- return (0);
-
-} #-- End of subroutine generate_index
-
-#------------------------------------------------------------------------------
-# Get all the metrics available
+# Get all the metrics available
#
# (gp-display-text) metric_list
# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
my $outputdir = ${ $outputdir_ref };
my $ignore_value;
- my $gp_functions_cmd;
- my $gp_display_text_cmd;
+ my $gp_functions_cmd;
+ my $gp_display_text_cmd;
my $metrics_output_file = $outputdir . "metrics-all";
my $result_file = $outputdir . $g_gp_output_file;
my @metrics_data = ();
- open (SCRIPT_METRICS, ">", $script_file_metrics)
+ open (SCRIPT_METRICS, ">", $script_file_metrics)
or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'");
gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing");
if ($error_code != 0)
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
gp_message ("abort", $subr_name, "execution terminated");
}
- open (METRICS_INFO, "<", $metrics_output_file)
+ open (METRICS_INFO, "<", $metrics_output_file)
or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'");
gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading");
} #-- End of subroutine get_basename
#------------------------------------------------------------------------------
-# Get the details on the experiments and store these in a file. Each
+# Get the details on the experiments and store these in a file. Each
# experiment has its own file. This makes the processing easier.
#------------------------------------------------------------------------------
sub get_experiment_info
my $cmd_output;
my $current_slot;
my $error_code;
- my $exp_info_file;
+ my $exp_info_file;
my @exp_info = ();
my @experiment_data = ();
my $gp_error_file;
my $gp_display_text_cmd;
- my $gp_functions_cmd;
- my $gp_log_file;
+ my $gp_functions_cmd;
+ my $gp_log_file;
my $ignore_value;
+ my $msg;
my $overview_file;
my $result_file;
my $script_file;
$gp_log_file = $outputdir . $g_gp_output_file;
$gp_error_file = $outputdir . $g_gp_error_logfile;
- open (SCRIPT_EXPERIMENT_INFO, ">", $script_file)
+ open (SCRIPT_EXPERIMENT_INFO, ">", $script_file)
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
if ($error_code != 0)
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
gp_message ("abort", $subr_name, "execution terminated");
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The first file has the following format:
#
# ID Sel PID Experiment
# == === ======= ======================================================
# 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er
# 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er
-#-------------------------------------------------------------------------------
- open (EXP_INFO, "<", $exp_info_file)
+#------------------------------------------------------------------------------
+ open (EXP_INFO, "<", $exp_info_file)
or die ("$subr_name - unable to open file $exp_info_file for reading '$!'");
gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading");
chomp (@exp_info = <EXP_INFO>);
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD - Check for the groups to exist below:
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$current_slot = 0;
for my $i (0 .. $#exp_info)
{
}
else
{
- my $msg = "remainder = $remainder has an unexpected format";
+ $msg = "remainder = $remainder has an unexpected format";
gp_message ("assertion", $subr_name, $msg);
}
}
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The experiment IDs and names are known. We can now generate the info for
# each individual experiment.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$gp_log_file = $outputdir . $g_gp_output_file;
$gp_error_file = $outputdir . $g_gp_error_logfile;
$script_file = $outputdir . "gp-details-exp.script";
- open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file)
+ open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file)
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
$gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
- gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment details");
+ $msg = "executing $GP_DISPLAY_TEXT to get the experiment details";
+ gp_message ("debug", $subr_name, $msg);
$gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
if ($error_code != 0)
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This is unlikely to happen, but you never know.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
gp_message ("abort", $subr_name, "execution terminated");
}
} #-- End of subroutine getfilesize
#------------------------------------------------------------------------------
-# Parse the fsummary output and for all functions, store all the information
-# found in "function_info". In addition to this, several derived structures
+# Parse the fsummary output and for all functions, store all the information
+# found in "function_info". In addition to this, several derived structures
# are stored as well, making this structure a "onestop" place to get all the
# info that is needed.
#------------------------------------------------------------------------------
sub get_function_info
-{
+{
my $subr_name = get_my_name ();
my ($FSUMMARY_FILE) = @_;
#------------------------------------------------------------------------------
my %functions_index = ();
+ my $msg;
+
# TBD: check
my $full_address_field;
my %source_files = ();
#
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
# Functions sorted by metric: Exclusive Total CPU Time
-#
+#
# <Total>
# Exclusive Total CPU Time: 11.538 (100.0%)
# Inclusive Total CPU Time: 11.538 (100.0%)
# Load Object: <Total>
# Mangled Name:
# Aliases:
-#
+#
# a_function_name
# Exclusive Total CPU Time: 4.003 ( 34.7%)
# Inclusive Total CPU Time: 4.003 ( 34.7%)
# Size: 715
# PC Address: 2:0x00006c61
-# Source File: <absolute path to source file>
-# Object File: <object filename>
+# Source File: <absolute path to source file>
+# Object File: <object filename>
# Load Object: <executable name>
# Mangled Name:
# Aliases:
{
$g_multi_count_function{$routine} = $TRUE;
}
- my $msg = "g_function_occurrences{$routine} = " .
- $g_function_occurrences{$routine};
+ $msg = "g_function_occurrences{$routine} = ";
+ $msg .= $g_function_occurrences{$routine};
gp_message ("debugXL", $subr_name, $msg);
}
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"});
#------------------------------------------------------------------------------
-# The $functions_index hash contains an array. After an initial assignment,
+# The $functions_index hash contains an array. After an initial assignment,
# other values that have been found are pushed onto the arrays.
#------------------------------------------------------------------------------
if (not exists ($functions_index{$routine}))
{
$functions_index{$routine} = [$i];
- }
- else
+ }
+ else
{
#------------------------------------------------------------------------------
# Add the array index to the list
}
else
{
- my $msg = "unexpected: number of fields = " . $no_of_elements;
+ $msg = "unexpected: number of fields = " . $no_of_elements;
gp_message ("assertion", $subr_name, $msg);
}
#------------------------------------------------------------------------------
my $offset;
#------------------------------------------------------------------------------
# The format of the address is assumed to be the following 2:0x000070a8
-# Note that the regex is pretty wide. This is from the original code and
+# Note that the regex is pretty wide. This is from the original code and
# could be made more specific:
# if ($value =~ /\s*(\S+):(\S+)/)
#------------------------------------------------------------------------------
$address_decimal = bigint::hex ($offset); # decimal
#------------------------------------------------------------------------------
# Construct the address field. Note that we use the hex address here.
+# For example @2:0x0003f280
#------------------------------------------------------------------------------
- $full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280
+ $full_address_field = '@'.$segment.":0x".$offset;
$function_info[$i]{"addressobj"} = $address_decimal;
$function_info[$i]{"addressobjtext"} = $full_address_field;
{
$function_address_and_index{$routine}{$value} = $i;
- my $msg = "function_address_and_index{$routine}{$value} = " .
- $function_address_and_index{$routine}{$value};
+ $msg = "function_address_and_index{$routine}{$value} = ";
+ $msg .= $function_address_and_index{$routine}{$value};
gp_message ("debugXL", $subr_name, $msg);
- }
- else
+ }
+ else
{
- gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address");
- }
+ $msg = "function_info: $FSUMMARY_FILE: function $routine";
+ $msg .= " already has a PC Address";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
$number_of_functions++;
}
}
close (FSUMMARY_FILE);
-
+
#------------------------------------------------------------------------------
# For every function in the function overview, set up an html structure with
# the various hyperlinks.
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "augment function_info with alt_name");
- my $target_function;
+ my $target_function;
my $html_line;
my $ftag;
- my $routine_length;
+ my $routine_length;
my %html_source_functions = ();
for my $i (keys @function_info)
{
#------------------------------------------------------------------------------
my $loadobj = $function_info[$i]{"Load Object"};
my $address_field = $function_info[$i]{"addressobjtext"};
- my $address_offset;
+ my $address_offset;
#------------------------------------------------------------------------------
# The address field has the following format: @<n>:<address_offset>
gp_message ("debug", $subr_name, "augment function_info with alt_name completed");
#------------------------------------------------------------------------------
-# Compute the maximum function name length.
+# Compute the maximum function name length.
#
# The maximum length is stored in %function_view_structure.
#------------------------------------------------------------------------------
my $max_function_length = 0;
for my $i (0 .. $#function_info)
{
- $max_function_length = max ($max_function_length, $function_info[$i]{"function length"});
+ $max_function_length = List::Util::max ($max_function_length, $function_info[$i]{"function length"});
gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"});
}
my $top_of_table = $FALSE;
for my $i (keys @function_info)
{
- my $new_target_function;
+ my $new_target_function;
if (defined ($function_info[$i]{"alt_name"}))
{
if ($target_function eq "<Total>")
#------------------------------------------------------------------------------
# <Total> is a pseudo function and there is no source, or disassembly for it.
-# We could add a link to the caller-callee part, but this is currently not
+# We could add a link to the caller-callee part, but this is currently not
# done.
#------------------------------------------------------------------------------
{
}
#------------------------------------------------------------------------------
-# Create the block with the function name, in boldface, plus the links to the
+# Create the block with the function name, in boldface, plus the links to the
# source, disassembly and caller-callee views.
#------------------------------------------------------------------------------
$html_line .= $function_info[$i]{"href_caller_callee"};
}
- gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line");
+ $msg = "target_function = $target_function html_line = $html_line";
+ gp_message ("debugM", $subr_name, $msg);
$html_source_functions{$target_function} = $html_line;
#------------------------------------------------------------------------------
for my $i (keys %html_source_functions)
{
- gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
+ $msg = "html_source_functions{$i} = $html_source_functions{$i}";
+ gp_message ("debugM", $subr_name, $msg);
}
for my $i (keys @function_info)
{
- gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"});
+ $msg = "function_info[$i]{\"html function block\"} = ";
+ $msg .= $function_info[$i]{"html function block"};
+ gp_message ("debugM", $subr_name, $msg);
}
#------------------------------------------------------------------------------
{
for my $role (sort keys %{ $function_info[$i] })
{
- gp_message ("debug", $subr_name, "on return: function_info[$i]{$role} = $function_info[$i]{$role}");
+ $msg = "on return: function_info[$i]{$role} = ";
+ $msg .= $function_info[$i]{$role};
+ gp_message ("debugM", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
{
for my $fields (sort keys %{ $function_address_and_index{$F} })
{
- gp_message ("debug", $subr_name, "on return: function_address_and_index{$F}{$fields} = $function_address_and_index{$F}{$fields}");
+ $msg = "on return: function_address_and_index{$F}{$fields} = ";
+ $msg .= $function_address_and_index{$F}{$fields};
+ gp_message ("debugM", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
}
#------------------------------------------------------------------------------
-# Print the data structure %function_view_structure. This is a hash.
+# Print the data structure %function_view_structure. This is a hash.
#------------------------------------------------------------------------------
for my $F (keys %function_view_structure)
{
gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}");
if ($g_function_occurrences{$F} == 1)
{
- $number_of_unique_functions++;
+ $number_of_unique_functions++;
}
else
{
- $number_of_non_unique_functions++;
+ $number_of_non_unique_functions++;
}
}
#------------------------------------------------------------------------------
# TBD: Include in experiment data. Include names with multiple occurrences.
#------------------------------------------------------------------------------
- my $msg;
-
$msg = "Number of source files : " .
$num_source_files;
gp_message ("debug", $subr_name, $msg);
- $msg = "Total number of functions: $number_of_functions";
+ $msg = "Total number of functions: $number_of_functions";
gp_message ("debug", $subr_name, $msg);
$msg = "Number of functions functions with a unique name : " .
- $number_of_unique_functions;
+ $number_of_unique_functions;
gp_message ("debug", $subr_name, $msg);
$msg = "Number of functions functions with more than one occurrence : " .
- $number_of_non_unique_functions;
+ $number_of_non_unique_functions;
gp_message ("debug", $subr_name, $msg);
- my $multi_occurrences = $number_of_functions - $number_of_unique_functions;
+ my $multi_occurrences = $number_of_functions - $number_of_unique_functions;
$msg = "Total number of multiple occurences of the same function name : " .
- $multi_occurrences;
+ $multi_occurrences;
gp_message ("debug", $subr_name, $msg);
- return (\@function_info, \%function_address_and_index, \%addressobjtextm,
+ return (\@function_info, \%function_address_and_index, \%addressobjtextm,
\%LINUX_vDSO, \%function_view_structure);
} #-- End of subroutine get_function_info
{
$ASORTFILE=$outputdir."calls";
$metric = "calls"
- }
+ }
elsif ($file eq $outputdir."calltree.sort.func")
{
$ASORTFILE=$outputdir."calltree";
last;
}
close (ASORTFILE);
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Ruud - Fixed a bug. The output should not be appended, but overwritten.
# open (HI,">>$OUTPUTDIR"."hdrinfo");
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $outfile = $outputdir."hdrinfo";
if ($first_call)
} #-- End of subroutine get_hdr_info
#------------------------------------------------------------------------------
-# Get the home directory and the location(s) of the configuration file on the
+# Get the home directory and the location(s) of the configuration file on the
# current system.
#------------------------------------------------------------------------------
sub get_home_dir_and_rc_path
$target_cmd = $g_mapped_cmds{"printenv"} . " HOME";
($error_code, $home_dir) = execute_system_cmd ($target_cmd);
-
+
if ($error_code != 0)
{
- my $msg = "cannot find a setting for HOME - please set this";
+ my $msg = "cannot find a setting for HOME - please set this";
gp_message ("assertion", $subr_name, $msg);
}
else
#------------------------------------------------------------------------------
-# The home directory is known and we can define the locations for the
+# The home directory is known and we can define the locations for the
# configuration file.
#------------------------------------------------------------------------------
{
@rc_file_paths = (".", "$home_dir");
- }
-
+ }
+
gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths");
return ($home_dir, \@rc_file_paths);
#------------------------------------------------------------------------------
# Get the summary of the hot functions
#------------------------------------------------------------------------------
- open (SCRIPT, ">", $script_file)
+ open (SCRIPT, ">", $script_file)
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
if ($error_code != 0)
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
gp_message ("abort", $subr_name, "execution terminated");
my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd";
gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset");
-
+
#------------------------------------------------------------------------------
# TBD: Do this substitution when storing "addressobjtext" in function_info.
#------------------------------------------------------------------------------
} #-- End of subroutine get_index_function_info
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Get the setting for LANG, or assign a default if it is not set.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub get_LANG_setting
{
my $subr_name = get_my_name ();
my $error_code;
my $lang_setting;
my $target_cmd;
- my $command_string;
+ my $command_string;
my $LANG;
$target_cmd = $g_mapped_cmds{"printenv"};
#------------------------------------------------------------------------------
# Use the printenv command to get the settings for LANG.
#------------------------------------------------------------------------------
- if ($target_cmd eq "road_to_nowhere")
+ if ($target_cmd eq "road to nowhere")
{
$error_code = 1;
}
my @exp_dir_list = @{ $exp_dir_list_ref };
- my $cmd_options;
- my $cmd_output;
+ my $cmd_options;
+ my $cmd_output;
my $error_code;
my $expr_name;
my $metrics_cmd;
# to get all the output in files $outfile1 and $outfile2. These are then
# parsed.
#------------------------------------------------------------------------------
- $cmd_options = " -viewmode machine -compare off -thread_select all";
+ $cmd_options = " -viewmode machine -compare off -thread_select all";
$cmd_options .= " -outfile $outfile2";
$cmd_options .= " -fsingle '<Total>' -metric_list $expr_name";
($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd);
#------------------------------------------------------------------------------
-# Error handling. Any error that occurred is fatal and execution
+# Error handling. Any error that occurred is fatal and execution
# should be aborted by the caller.
#------------------------------------------------------------------------------
if ($error_code == 0)
} #-- End of subroutine get_my_name
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Determine the characteristics of the current system
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub get_system_config_info
{
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
my $subr_name = get_my_name ();
- my $target_cmd;
- my $hostname_current;
my $error_code;
- my $ignore_output;
+ my $hostname_current;
+ my $ignore_output;
+ my $msg;
+ my $target_cmd;
#------------------------------------------------------------------------------
-# Test once if the command succeeds. This avoids we need to check every
+# Test once if the command succeeds. This avoids we need to check every
# specific # command below.
#------------------------------------------------------------------------------
$target_cmd = $g_mapped_cmds{uname};
($error_code, $ignore_output) = execute_system_cmd ($target_cmd);
-
+
if ($error_code != 0)
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This is unlikely to happen, but you never know.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
gp_message ("abort", $subr_name, "failure to execute the uname command");
}
-
+
my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name);
my $nodename = qx ($target_cmd -n); chomp ($nodename);
my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release);
my $processor = qx ($target_cmd -p); chomp ($processor);
my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform);
my $operating_system = qx ($target_cmd -o); chomp ($operating_system);
-
+
$local_system_config{"kernel_name"} = $kernel_name;
$local_system_config{"nodename"} = $nodename;
$local_system_config{"kernel_release"} = $kernel_release;
$local_system_config{"processor"} = $processor;
$local_system_config{"hardware_platform"} = $hardware_platform;
$local_system_config{"operating_system"} = $operating_system;
-
+
gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:");
gp_message ("debug", $subr_name, "kernel_name = $kernel_name");
gp_message ("debug", $subr_name, "nodename = $nodename");
gp_message ("debug", $subr_name, "processor = $processor");
gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform");
gp_message ("debug", $subr_name, "operating_system = $operating_system");
-
+
#------------------------------------------------------------------------------
# Check if the system we are running on is supported.
#------------------------------------------------------------------------------
if (not $is_supported)
{
- gp_message ("error", $subr_name, "$machine is not supported");
+ $msg = "the $machine instruction set architecture is not supported";
+ gp_message ("error", $subr_name, $msg);
+ gp_message ("diag", $subr_name, "Error: " . $msg);
+
+ $msg = "temporarily ignored for development purposes";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
exit (0);
}
#------------------------------------------------------------------------------
$target_cmd = $g_mapped_cmds{hostname};
$hostname_current = qx ($target_cmd); chomp ($hostname_current);
$error_code = ${^CHILD_ERROR_NATIVE};
-
+
if ($error_code == 0)
{
$local_system_config{"hostname_current"} = $hostname_current;
}
else
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This is unlikely to happen, but you never know.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
gp_message ("abort", $subr_name, "failure to execute the hostname command");
}
} #-- End of subroutine get_system_config_info
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# This subroutine prints a message. Several types of messages are supported.
-# In case the type is "abort", or "error", execution is terminated.
+# In case the type is "abort", or "error", execution is terminated.
#
-# Note that "debug", "warning", and "error" mode, the name of the calling
-# subroutine is truncated to 30 characters. In case the name is longer,
+# Note that "debug", "warning", and "error" mode, the name of the calling
+# subroutine is truncated to 30 characters. In case the name is longer,
# a warning message # is issued so you know this has happened.
#
-# Note that we use lcfirst () and ucfirst () to enforce whether the first
+# Note that we use lcfirst () and ucfirst () to enforce whether the first
# character is printed in lower or uppercase. It is nothing else than a
# convenience, but creates more consistency across messages.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub gp_message
{
my $subr_name = get_my_name ();
my ($action, $caller_name, $comment_line) = @_;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The debugXL identifier is special. It is accepted, but otherwise ignored.
# This allows to (temporarily) disable debug print statements, but keep them
# around.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my %supported_identifiers = (
- "verbose" => "[Verbose]",
- "debug" => "[Debug]",
- "error" => "[Error]",
- "warning" => "[Warning]",
- "abort" => "[Abort]",
+ "verbose" => "[Verbose]",
+ "debug" => "[Debug]",
+ "error" => "[Error]",
+ "warning" => "[Warning]",
+ "abort" => "[Abort]",
"assertion" => "[Assertion error]",
- "diag" => "",
+ "diag" => "",
);
- my $debug_size;
+ my $debug_size;
my $identifier;
- my $fixed_size_name;
+ my $fixed_size_name;
+ my $ignore_value;
my $string_limit = 30;
my $strlen = length ($caller_name);
my $trigger_debug = $FALSE;
- my $truncated_name;
+ my $truncated_name;
my $msg;
if ($action =~ /debug\s*(.+)/)
{
if ($g_debug_size{$debug_size})
{
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# All we need to know is whether a debug action is requested and whether the
# size has been enabled. By setting $action to "debug", the code below is
# simplified. Note that only using $trigger_debug below is actually sufficient.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
$trigger_debug = $TRUE;
}
}
$trigger_debug = $TRUE;
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Catch any non-supported identifier.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if (defined ($supported_identifiers{$action}))
{
$identifier = $supported_identifiers{$action};
{
die ("$subr_name - input error: $action is not supported");
}
- if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off"))
+ if (($action eq "debug") and (not $g_debug))
{
$trigger_debug = $FALSE;
}
-#-------------------------------------------------------------------------------
-# Unconditionally buffer all warning messages. These are meant to be displayed
-# separately.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Unconditionally buffer all warning messages. These are available through the
+# index.html page and cannot be disabled.
+#
+# If the quiet mode has been enabled, warnings are not printed though.
+#------------------------------------------------------------------------------
if ($action eq "warning")
{
- push (@g_warning_messages, ucfirst ($comment_line));
+#------------------------------------------------------------------------------
+# Remove any leading <br>, capitalize the first letter, and put the <br> back
+# before storing the message in the buffer.
+#------------------------------------------------------------------------------
+ if ($comment_line =~ /^$g_html_new_line/)
+ {
+ $msg = $comment_line;
+ $msg =~ s/$g_html_new_line//;
+ $comment_line = $g_html_new_line . ucfirst ($msg);
+
+ push (@g_warning_msgs, $comment_line);
+ }
+ else
+ {
+ push (@g_warning_msgs, ucfirst ($comment_line));
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Unconditionally buffer all errror messages. These will be printed prior to
+# terminate execution.
+#------------------------------------------------------------------------------
+ if ($action eq "error")
+#------------------------------------------------------------------------------
+# Remove any leading <br>, capitalize the first letter, and put the <br> back.
+#------------------------------------------------------------------------------
+ {
+ if ($comment_line =~ /^$g_html_new_line/)
+ {
+ $msg = $comment_line;
+ $msg =~ s/$g_html_new_line//;
+ $comment_line = $g_html_new_line . ucfirst ($msg);
+
+ push (@g_error_msgs, $comment_line);
+ }
+ else
+ {
+ push (@g_error_msgs, ucfirst ($comment_line));
+ }
}
-#-------------------------------------------------------------------------------
-# Quick return in several cases. Note that "debug", "verbose", "warning", and
+#------------------------------------------------------------------------------
+# Quick return in several cases. Note that "debug", "verbose", "warning", and
# "diag" messages are suppressed in quiet mode, but "error", "abort" and
# "assertion" always pass.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ((
($action eq "verbose") and (not $g_verbose))
or (($action eq "debug") and (not $trigger_debug))
- or (($action eq "verbose") and ($g_quiet))
- or (($action eq "debug") and ($g_quiet))
- or (($action eq "warning") and (not $g_warnings))
+ or (($action eq "verbose") and ($g_quiet))
+ or (($action eq "debug") and ($g_quiet))
+ or (($action eq "warning") and ($g_quiet))
or (($action eq "diag") and ($g_quiet)))
{
return (0);
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# In diag mode, just print the input line and nothing else.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ((
- $action eq "debug")
+ $action eq "debug")
or ($action eq "abort")
- or ($action eq "warning")
- or ($action eq "assertion")
- or ($action eq "error"))
- {
-#-------------------------------------------------------------------------------
-# Construct the string to be printed. Include an identifier and the name of
-# the function.
-#-------------------------------------------------------------------------------
+ or ($action eq "assertion"))
+## or ($action eq "error"))
+ {
+#------------------------------------------------------------------------------
+# Construct the string to be printed. Include an identifier and the name of
+# the function.
+#------------------------------------------------------------------------------
if ($strlen > $string_limit)
{
$truncated_name = substr ($caller_name, 0, $string_limit);
$fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name);
- print "Warning in $subr_name - the name of the caller is: $caller_name\n";
- print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n";
+ print "Warning in $subr_name - the name of the caller is: " .
+ $caller_name . "\n";
+ print "Warning in $subr_name - the string length is $strlen and " .
+ "exceeds $string_limit\n";
}
else
{
$fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name);
}
- if (($action eq "error") or ($action eq "abort"))
-#-------------------------------------------------------------------------------
+## if (($action eq "error") or ($action eq "abort"))
+ if ($action eq "abort")
+#------------------------------------------------------------------------------
# Enforce that the message starts with a lowercase symbol. Since these are
# user errors, the name of the routine is not shown. The same for "abort".
# If you want to display the routine name too, use an assertion.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- printf ("%-9s %s\n", $identifier, lcfirst ($comment_line));
+ my $error_identifier = $supported_identifiers{"error"};
+ if (@g_error_msgs)
+ {
+ $ignore_value = print_errors_buffer (\$error_identifier);
+ }
+ printf ("%-9s %s", $identifier, ucfirst ($comment_line));
+ printf (" - %s\n", "execution is terminated");
}
elsif ($action eq "assertion")
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Enforce that the message starts with a lowercase symbol.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
+#------------------------------------------------------------------------------
+# The lines are too long, but breaking the argument list gives this warning:
+# printf (...) interpreted as function
+#------------------------------------------------------------------------------
+ printf ("%-17s %-30s", $identifier, $fixed_size_name);
+ printf (" - %s\n", $comment_line);
}
elsif (($action eq "debug") and ($trigger_debug))
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Debug messages are printed "as is". Avoids issues when searching for them ;-)
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
+ printf ("%-9s %-30s", $identifier, $fixed_size_name);
+ printf (" - %s\n", $comment_line);
}
else
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Enforce that the message starts with a lowercase symbol.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
- printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line));
+ printf ("%-9s %-30s", $identifier, $fixed_size_name);
+ printf (" - %s\n", $comment_line);
}
}
elsif ($action eq "verbose")
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The first character in the verbose message is capatilized.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
printf ("%s\n", ucfirst ($comment_line));
}
elsif ($action eq "diag")
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# The diag messages are meant to be diagnostics. Only the comment line is
# printed.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
{
printf ("%s\n", $comment_line);
return (0);
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Terminate execution in case the identifier is "abort".
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if (($action eq "abort") or ($action eq "assertion"))
{
## print "ABORT temporarily disabled for testing purposes\n";
{
return (0);
}
-
+
} #-- End of subroutine gp_message
#------------------------------------------------------------------------------
-# Dynamically load the modules needed. Returns a list with the modules that
-# could not be loaded.
+# Create an HTML page with the warnings. If there are no warnings, include
+# line to this extent. The alternative is to supporess the entire page, but
+# that breaks the consistency in the output.
#------------------------------------------------------------------------------
-sub handle_module_availability
+sub html_create_warnings_page
{
my $subr_name = get_my_name ();
- gp_message ("verbose", $subr_name, "Handling module requirements");
+ my ($outputdir_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+
+ my $file_title;
+ my $html_acknowledgement;
+ my $html_end;
+ my $html_header;
+ my $html_home_left;
+ my $html_home_right;
+ my $html_title_header;
+ my $msg_no_warnings = "There are no warning messages issued.";
+ my $page_title;
+ my $position_text;
+ my $size_text;
+
+ my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html";
+
+ gp_message ("debug", $subr_name, "outfile = $outfile");
+
+ open (WARNINGS_OUT, ">", $outfile)
+ or die ("unable to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ gp_message ("debug", $subr_name, "building warning file $outfile");
#------------------------------------------------------------------------------
-# This is clunky at best, but there is a chicken egg problem here. For the
-# man page to be generated, the --help and --version options need to work,
-# but this part of the code only works if the "stat" function is available.
-# The "feature qw (state)" is required for the code to compile.
-#
-# TBD: Consider using global variables and to decouple parts of the option
-# handling.
-#;
-## my @modules_used = ("feature",
-## "File::stat",
+# Generate some of the structures used in the HTML output.
#------------------------------------------------------------------------------
- my @modules_used = (
- "List::Util",
- "Cwd",
- "File::Basename",
- "File::stat",
- "POSIX",
- "bigint",
- "bignum");
+ $file_title = "Warning messages";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home_right = ${ generate_home_link ("right") };
+
+ $page_title = "Warning Messages";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
- my @missing_modules = ();
- my $cmd;
- my $result;
-
#------------------------------------------------------------------------------
-# This loop checks for the availability of the modules and if so, imports
-# the module.
-#
-# The names of missing modules, if any, are stored and printed in the error
-# handling section below.
+# Get the acknowledgement, return to main link, and final html statements.
+#------------------------------------------------------------------------------
+ $html_home_left = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
#------------------------------------------------------------------------------
- for my $i (0 .. $#modules_used)
+# Generate the HTML file.
+#------------------------------------------------------------------------------
+ print WARNINGS_OUT $html_header;
+ print WARNINGS_OUT $html_home_right;
+ print WARNINGS_OUT $html_title_header;
+
+ if ($g_total_warning_count > 0)
{
- my $m = $modules_used[$i];
- if (eval "require $m;")
- {
- if ($m eq "feature")
- {
- $cmd = $m . "->import ( qw (state))";
- }
- elsif ($m eq "List::Util")
- {
- $cmd = $m . "->import ( qw (min max))";
- }
- elsif ($m eq "bigint")
- {
- $cmd = $m . "->import ( qw (hex))";
- }
- else
- {
- $cmd = $m . "->import";
- }
- $cmd .= ";";
- $result = eval ("$cmd");
- gp_message ("debugM", $subr_name, "cmd = $cmd");
- }
- else
- {
- push (@missing_modules, $m);
- }
+ print WARNINGS_OUT "<pre>\n";
+ print WARNINGS_OUT "$_\n" for @g_warning_msgs;
+ print WARNINGS_OUT "</pre>\n";
}
+ else
+ {
+ print WARNINGS_OUT $msg_no_warnings;
+ }
+
+ print WARNINGS_OUT $html_home_left;
+ print WARNINGS_OUT "<br>\n";
+ print WARNINGS_OUT $html_acknowledgement;
+ print WARNINGS_OUT $html_end;
+
+ close (WARNINGS_OUT);
+
+ return (0);
+
+} #-- End of subroutine html_create_warnings_page
#------------------------------------------------------------------------------
-# Count the number of missing modules. It is upon the caller to decide what
-# to do in case of errors. Currently, execution is aborted.
+# Generate the HTML with the experiment summary.
#------------------------------------------------------------------------------
- my $errors = scalar (@missing_modules);
+sub html_generate_exp_summary
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref, $experiment_data_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+ my @experiment_data = @{ $experiment_data_ref };
+ my $file_title;
+ my $outfile;
+ my $page_title;
+ my $size_text;
+ my $position_text;
+ my $html_header;
+ my $html_home;
+ my $html_title_header;
+ my $html_acknowledgement;
+ my $html_end;
+ my @html_exp_table_data = ();
+ my $html_exp_table_data_ref;
+ my @table_execution_stats = ();
+ my $table_execution_stats_ref;
- return (\$errors, \@missing_modules);
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+ $outputdir = append_forward_slash ($outputdir);
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
-} #-- End of subroutine handle_module_availability
+ $file_title = "Experiment information";
+ $page_title = "Experiment Information";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home = ${ generate_home_link ("right") };
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+ $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html";
+ open (EXP_INFO, ">", $outfile)
+ or die ("unable to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ print EXP_INFO $html_header;
+ print EXP_INFO $html_home;
+ print EXP_INFO $html_title_header;
+
+ ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref);
+
+ @html_exp_table_data = @{ $html_exp_table_data_ref };
+ @table_execution_stats = @{ $table_execution_stats_ref };
+
+ print EXP_INFO "$_" for @html_exp_table_data;
+;
+## print EXP_INFO "<pre>\n";
+## print EXP_INFO "$_\n" for @html_caller_callee;
+## print EXP_INFO "</pre>\n";
+
+#------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#------------------------------------------------------------------------------
+ $html_home = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
+ print EXP_INFO $html_home;
+ print EXP_INFO "<br>\n";
+ print EXP_INFO $html_acknowledgement;
+ print EXP_INFO $html_end;
+
+ close (EXP_INFO);
+
+ return (\@table_execution_stats);
+
+} #-- End of subroutine html_generate_exp_summary
+
+#------------------------------------------------------------------------------
+# Generate the index.html file.
+#------------------------------------------------------------------------------
+sub html_generate_index
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref,
+ $number_of_metrics_ref, $function_info_ref, $function_address_info_ref,
+ $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref,
+ $metric_description_reversed_ref, $table_execution_stats_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+ my $html_first_metric_file = ${ $html_first_metric_file_ref };
+ my $summary_metrics = ${ $summary_metrics_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_address_info = %{ $function_address_info_ref };
+ my @sort_fields = @{ $sort_fields_ref };
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+ my %addressobjtextm = %{ $addressobjtextm_ref };
+ my %metric_description_reversed = %{ $metric_description_reversed_ref };
+ my @table_execution_stats = @{ $table_execution_stats_ref };
+
+ my @file_contents = ();
+
+ my $acknowledgement;
+ my @abs_path_exp_dirs = ();
+ my $input_experiments;
+ my $target_function;
+ my $html_line;
+ my $ftag;
+ my $max_length = 0;
+ my %html_source_functions = ();
+ my $html_header;
+ my @experiment_directories = ();
+ my $html_acknowledgement;
+ my $html_file_title;
+ my $html_output_file;
+ my $html_function_view;
+ my $html_caller_callee_view;
+ my $html_experiment_info;
+ my $html_warnings_page;
+ my $href_link;
+ my $file_title;
+ my $html_gprofng;
+ my $html_end;
+ my $max_length_metrics;
+ my $page_title;
+ my $size_text;
+ my $position_text;
+
+ my $ln;
+ my $base;
+ my $base_index_page;
+ my $infile;
+ my $outfile;
+ my $rec;
+ my $skip;
+ my $callsize;
+ my $dest;
+ my $final_string;
+ my @headers;
+ my $header;
+ my $sort_index;
+ my $pc_address;
+ my $anchor;
+ my $directory_name;
+ my $f2;
+ my $f3;
+ my $file;
+ my $sline;
+ my $src;
+ my $srcfile_name;
+ my $tmp1;
+ my $tmp2;
+ my $fullsize;
+ my $regf2;
+ my $trimsize;
+ my $EIL;
+ my $EEIL;
+ my $AOBJ;
+ my $RI;
+ my $HDR;
+ my $CALLER_CALLEE;
+ my $NAME;
+ my $SRC;
+ my $TRIMMED;
+
+#------------------------------------------------------------------------------
+# Add a forward slash to make it easier when creating file names.
+#------------------------------------------------------------------------------
+ $outputdir = append_forward_slash ($outputdir);
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+
+ my $LANG = $g_locale_settings{"LANG"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ $input_experiments = join (", ", @exp_dir_list);
+
+ for my $i (0 .. $#exp_dir_list)
+ {
+ my $dir = get_basename ($exp_dir_list[$i]);
+ push @abs_path_exp_dirs, $dir;
+ }
+ $input_experiments = join (", ", @abs_path_exp_dirs);
+
+ gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
+
#------------------------------------------------------------------------------
-# Generate the HTML with the experiment summary.
+# TBD: Pass in the values for $expr_name and $cmd
#------------------------------------------------------------------------------
-sub html_generate_exp_summary
-{
- my $subr_name = get_my_name ();
+ $html_file_title = "Main index page";
- my ($outputdir_ref, $experiment_data_ref) = @_;
+ @experiment_directories = split (",", $input_experiments);
+ $html_acknowledgement = ${ create_html_credits () };
- my $outputdir = ${ $outputdir_ref };
- my @experiment_data = @{ $experiment_data_ref };
- my $file_title;
- my $outfile;
- my $page_title;
- my $size_text;
- my $position_text;
- my $html_header;
- my $html_home;
- my $html_title_header;
- my $html_acknowledgement;
- my $html_end;
- my @html_exp_table_data = ();
- my $html_exp_table_data_ref;
- my @table_execution_stats = ();
- my $table_execution_stats_ref;
+ $html_end = ${ terminate_html_document () };
- gp_message ("debug", $subr_name, "outputdir = $outputdir");
- $outputdir = append_forward_slash ($outputdir);
- gp_message ("debug", $subr_name, "outputdir = $outputdir");
+ $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html";
- $file_title = "Experiment information";
- $page_title = "Experiment Information";
- $size_text = "h2";
+ open (INDEX, ">", $html_output_file)
+ or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
+
+ $page_title = "GPROFNG Performance Analysis";
+ $size_text = "h1";
$position_text = "center";
- $html_header = ${ create_html_header (\$file_title) };
- $html_home = ${ generate_home_link ("right") };
+ $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
- $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+ $html_header = ${ create_html_header (\$html_file_title) };
- $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html";
- open (EXP_INFO, ">", $outfile)
- or die ("unable to open $outfile for writing - '$!'");
- gp_message ("debug", $subr_name, "opened file $outfile for writing");
+ print INDEX $html_header;
+ print INDEX $html_gprofng;
+ print INDEX "$_" for @g_html_experiment_stats;
+ print INDEX "$_" for @table_execution_stats;
- print EXP_INFO $html_header;
- print EXP_INFO $html_home;
- print EXP_INFO $html_title_header;
+ $html_experiment_info = "<a href=\'";
+ $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html";
+ $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n";
- ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref);
+ $html_warnings_page = "<a href=\'";
+ $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html";
+ $html_warnings_page .= "\'><h3>Warnings (" . $g_total_warning_count;
+ $html_warnings_page .= ")</h3></a>\n";
- @html_exp_table_data = @{ $html_exp_table_data_ref };
- @table_execution_stats = @{ $table_execution_stats_ref };
+ $html_function_view = "<a href=\'";
+ $html_function_view .= $html_first_metric_file;
+ $html_function_view .= "\'><h3>Function View</h3></a>\n";
- print EXP_INFO "$_" for @html_exp_table_data;
-;
-## print EXP_INFO "<pre>\n";
-## print EXP_INFO "$_\n" for @html_caller_callee;
-## print EXP_INFO "</pre>\n";
+ $html_caller_callee_view = "<a href=\'";
+ $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html";
+ $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n";
-#-------------------------------------------------------------------------------
-# Get the acknowledgement, return to main link, and final html statements.
-#-------------------------------------------------------------------------------
- $html_home = ${ generate_home_link ("left") };
- $html_acknowledgement = ${ create_html_credits () };
- $html_end = ${ terminate_html_document () };
+ print INDEX "<br>\n";
+## print INDEX "<b>\n";
+ print INDEX $html_experiment_info;
+ print INDEX $html_warnings_page;
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
+ print INDEX $html_function_view;
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
+ print INDEX $html_caller_callee_view;
+## print INDEX "</b>\n";
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
- print EXP_INFO $html_home;
- print EXP_INFO "<br>\n";
- print EXP_INFO $html_acknowledgement;
- print EXP_INFO $html_end;
+ print INDEX $html_acknowledgement;
+ print INDEX $html_end;
- close (EXP_INFO);
+ close (INDEX);
- return (\@table_execution_stats);
+ gp_message ("debug", $subr_name, "closed file $html_output_file");
-} #-- End of subroutine html_generate_exp_summary
+ return (0);
-#-------------------------------------------------------------------------------
+} #-- End of subroutine html_generate_index
+
+#------------------------------------------------------------------------------
# Generate the entries for the tables with the experiment info.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub html_generate_table_data
{
my $subr_name = get_my_name ();
my @html_exp_table_data = ();
my $html_line;
## my $html_header_line;
- my $entry_name;
+ my $entry_name;
my $key;
- my $size_text;
+ my $size_text;
my $position_text;
- my $title_table_1;
- my $title_table_2;
- my $title_table_3;
- my $title_table_summary;
- my $html_table_title;
+ my $title_table_1;
+ my $title_table_2;
+ my $title_table_3;
+ my $title_table_summary;
+ my $html_table_title;
my @experiment_table_1_def = ();
my @experiment_table_2_def = ();
$title_table_3 = "Run Time Statistics";
$title_table_summary = "Main Statistics";
- $size_text = "h3";
+ $size_text = "h3";
$position_text = "left";
- push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"};
- push @experiment_table_1_def, { name => "Hostname" , key => "hostname"};
- push @experiment_table_1_def, { name => "Operating system", key => "OS"};
- push @experiment_table_1_def, { name => "Architecture", key => "architecture"};
- push @experiment_table_1_def, { name => "Page size", key => "page_size"};
-
- push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"};
- push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"};
- push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"};
- push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"};
-
- push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
-## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"};
- push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
-## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"};
- push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"};
-## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"};
-
- push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"};
- push @exp_table_summary_def, { name => "Hostname" , key => "hostname"};
- push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
- push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
- push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"};
+ push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"};
+ push @experiment_table_1_def, { name => "Hostname" , key => "hostname"};
+ push @experiment_table_1_def, { name => "Operating system", key => "OS"};
+ push @experiment_table_1_def, { name => "Architecture", key => "architecture"};
+ push @experiment_table_1_def, { name => "Page size", key => "page_size"};
+
+ push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"};
+ push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"};
+ push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"};
+ push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"};
+
+ push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
+## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"};
+ push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
+## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"};
+ push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"};
+## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"};
+
+ push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"};
+ push @exp_table_summary_def, { name => "Hostname" , key => "hostname"};
+ push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
+ push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
+ push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"};
$html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) };
my ($comment_ref, $error_file_ref) = @_;
- my $comment;
- my $error_file;
- my $error_message;
- my $file_title;
+ my $comment;
+ my $error_file;
+ my $error_message;
+ my $file_title;
my $html_end;
my $html_header;
- my $html_home;
+ my $html_home;
my @html_empty_file = ();
my ($filename) = @_;
- my $size;
- my $file_stat;
my $is_empty;
+ my $file_stat;
+ my $msg;
+ my $size;
chomp ($filename);
# The return value is used in the caller. This is why we return the empty
# string in case the file does not exist.
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "filename = $filename not found");
+ $msg = "filename = $filename not found";
+ gp_message ("debug", $subr_name, $msg);
$is_empty = $TRUE;
}
else
$is_empty = ($size == 0) ? $TRUE : $FALSE;
}
- gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty");
+ $msg = "filename = $filename size = $size is_empty = $is_empty";
+ gp_message ("debug", $subr_name, $msg);
return ($is_empty);
my $index_offset;
my $is_executable;
my $mode;
- my $number_of_bytes;
+ my $number_of_bytes;
my @permission_settings = ();
my %permission_values = ();
# Get username. We currently do not do anything with this though and the
# code is commented out.
#
-# my $my_name = getlogin () || getpwuid($<) || "Kilroy";;
+# my $my_name = getlogin () || getpwuid($<) || "Kilroy";
# gp_message ("debug", $subr_name, "my_name = $my_name");
#------------------------------------------------------------------------------
my $msg = "permission_values{" . $k . "} = " .
$permission_values{$k};
gp_message ("debugXL", $subr_name, $msg);
-
+
if ($permission_values{$k} % 2 == 0)
{
$is_executable = $FALSE;
} #-- End of subroutine is_file_executable
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Print a message after a failure in $GP_DISPLAY_TEXT.
+#------------------------------------------------------------------------------
+sub msg_display_text_failure
+{
+ my $subr_name = get_my_name ();
+
+ my ($gp_display_text_cmd, $error_code, $error_file) = @_;
+
+ my $msg;
+
+ $msg = "error code = $error_code - failure executing the following command:";
+ gp_message ("error", $subr_name, $msg);
+
+ gp_message ("error", $subr_name, $gp_display_text_cmd);
+
+ $msg = "check file $error_file for more details";
+ gp_message ("error", $subr_name, $msg);
+
+ return (0);
+
+} #-- End of subroutine msg_display_text_failure
+
+#------------------------------------------------------------------------------
# TBD.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub name_regex
{
my $subr_name = get_my_name ();
gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-");
-#-------------------------------------------------------------------------------
-# According to https://perldoc.perl.org/File::Basename, both dirname and
+#------------------------------------------------------------------------------
+# According to https://perldoc.perl.org/File::Basename, both dirname and
# basename are not reliable and fileparse () is recommended instead.
#
# Note that $gp_metrics_dir has a trailing "/".
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC");
gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file");
$rat = $_;
chomp ($rat);
gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics");
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Capture the string after "Current metrics:" and if it ends with ":name",
# remove it.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($rat =~ /^\s*Current metrics:\s*(.*)$/)
{
$new_metrics = $1;
if ($is_calls or $is_calltree)
{
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Remove any inclusive metrics from the list.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/)
{
$pre = $1;
gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-");
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Find the line starting with "address:" and strip this part away.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($metrics =~ /^address:(.*)/)
{
$reported_metrics = $1;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Focus on the filename ending with "-PC". When found, strip this part away.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
if ($file =~ /^(.*)-PC$/)
{
$noPCfile = $1;
}
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Split the list into an array with the individual metrics.
#
# TBD: This should be done only once!
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
@reported_metrics = split (":", $reported_metrics);
for my $i (@reported_metrics)
{
{
my $a;
my $am;
- $a = $m;
- $a =~ s/^a/e/;
+ $a = $m;
+ $a =~ s/^a/e/;
$am = ${ retrieve_metric_description (\$a, \%metric_description) };
$am =~ s/Exclusive/Attributed/;
push (@moo,"$m:$am\n");
if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree"))
{
$mf = $nf + 1;
- }
+ }
else
{
for my $candidate_metric (@splitted_metrics)
if ($mf == 1)
{
$re = "^\\s*(\\S+)"; # metric value
- }
- else
+ }
+ else
{
$re = "^\\s*\\S+";
}
if ($m == $mf)
{
$re .= "\\s+(\\S+)"; # metric value
- }
- else
+ }
+ else
{
$re .= "\\s+\\S+";
}
{
$re .= "\\s+.*\\+-(.*)"; # name
$Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?)
- }
- else
+ }
+ else
{
$re .= "\\s+(.*)"; # name
$Xre .= "\\s+(.*)\$"; # name
} #-- End of subroutine name_regex
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub nosrc
{
my $subr_name = get_my_name ();
#------------------------------------------------------------------------------
# TBD.
#------------------------------------------------------------------------------
-sub numerically
+sub numerically
{
my $f1;
my $f2;
$f2 = int ($2);
$f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1);
}
- }
- else
+ }
+ else
{
return ($a <=> $b);
}
#------------------------------------------------------------------------------
# Parse the user options. Also perform a basic check. More checks and also
-# some specific to the option will be performed after this subroutine.
+# some more specific to the option, plus cross option checks, will be
+# performed soon after this subroutine has executed.
+#
+# Warnings, but also errors, are buffered. In this way we can collect as many
+# warnings and errors as possible, before bailing out in case of an error.
#------------------------------------------------------------------------------
sub parse_and_check_user_options
{
my $subr_name = get_my_name ();
- my ($no_of_args_ref, $option_list_ref) = @_;
-
- my $no_of_args = ${ $no_of_args_ref };
- my @option_list = @{ $option_list_ref };
-
my @exp_dir_list;
my $arg;
- my $calltree_value;
- my $debug_value;
- my $default_metrics_value;
- my $func_limit_value;
+ my $calltree_value;
+ my $debug_value;
+ my $default_metrics_value;
+ my $func_limit_value;
my $found_exp_dir = $FALSE;
- my $ignore_metrics_value;
+ my $ignore_metrics_value;
my $ignore_value;
- my $message;
+ my $msg;
my $outputdir_value;
- my $quiet_value;
+ my $quiet_value;
my $hp_value;
my $valid;
- my $verbose_value;
+ my $verbose_value;
+
+ my $number_of_fields;
+
+ my $internal_option_name;
+ my $option_name;
+
+ my $verbose = undef;
+ my $warning = undef;
+
+ my @opt_debug = ();
+ my @opt_highlight_percentage = ();
+ my @opt_nowarnings = ();
+ my @opt_obsoleted_hp = ();
+ my @opt_output = ();
+ my @opt_overwrite = ();
+ my @opt_quiet = ();
+ my @opt_verbose = ();
+ my @opt_warnings = ();
+
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+ my $no_of_warnings;
+ my $total_warning_msgs = 0;
+ my $option_value;
+ my $option_warnings;
+ my $no_of_warnings_ref;
+ my $no_of_errors_ref;
+
+ my $index_exp;
+ my $first = $TRUE;
+ my $trigger = $FALSE;
+ my $found_non_exp = $FALSE;
+ my $name_non_exp_dir;
+ my $no_of_experiments = 0;
+
+ my @opt_help = ();
+ my @opt_version = ();
+ my $stop_execution = $FALSE;
- $no_of_args++;
+ my $option_value_ref;
+ my $max_occurrences;
+#------------------------------------------------------------------------------
+# Configure Getopt to:
+# - Silence warnings, since these are handled by the code.
+# - Enforce case sensitivity in order to support -o and -O for example.
+#------------------------------------------------------------------------------
+ Getopt::Long::Configure("pass_through", "no_ignore_case");
- gp_message ("debug", $subr_name, "no_of_args = $no_of_args");
- gp_message ("debug", $subr_name, "option_list = @option_list");
+#------------------------------------------------------------------------------
+# Check for the --help and --version options. Print a message and exit.
+# Note that we support using both options simultaneously on the command line.
+#------------------------------------------------------------------------------
+ GetOptions (
+ "help" => \@opt_help,
+ "version" => \@opt_version
+ );
- my $option_errors = 0;
+ if (@opt_help)
+ {
+ $stop_execution = $TRUE;
+ $ignore_value = print_help_info ();
+ }
+ if (@opt_version)
+ {
+ $stop_execution = $TRUE;
+ $ignore_value = print_version_info ();
+ }
- while (defined ($arg = shift @ARGV))
+ if ($stop_execution)
{
- gp_message ("debug", $subr_name, "parsing options arg = $arg");
- gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV");
+ exit (0);
+ }
+
+#------------------------------------------------------------------------------
+# First, scan ARGV for the experiment names. If there are no names, or the
+# list with the names is not contiguous (meaning there is an non-experiment
+# name in this list), an error message is printed and execution is terminated.
+#
+# Upon return from this function, the list with the experiment names is
+# known and has been removed from ARGV.
+#
+# As a result, exp_dir_list is available from there on.
+#
+# This makes the subsequent processing of ARGV with GetOptions() easier.
+#------------------------------------------------------------------------------
+ @exp_dir_list = @{ check_the_experiment_list () };
#------------------------------------------------------------------------------
-# The gprofng driver adds this option. We need to get rid of it.
+# Configure Getopt to:
+# - Silence warnings, since these are handled by the code.
+# - Enforce case sensitivity in order to support -o and -O for example.
+# - Allow unique abbreviations (also the default).
+#------------------------------------------------------------------------------
+ Getopt::Long::Configure("pass_through", "no_ignore_case", "auto_abbrev");
+#------------------------------------------------------------------------------
+# Get the remaining command line options.
+#
+# Recall:
+# = => option requires a value
+# : => option value is optional
#------------------------------------------------------------------------------
- next if ($arg eq "--whoami=gprofng display html");
#------------------------------------------------------------------------------
-# Parse the input options and check for the values to be valid.
+# All options are considered to be a string.
#
-# Valid values are stored in the main option table.
+# We request every option supported to have an optional value. Otherwise,
+# GetOptions skips an option that does not have a value.
#
-# TBD: The early check handles some of these already and the duplicates
-# can be removed. Be aware of some global settings though.
+# The logic that parses the options deals with this and checks if an option
+# that should have a value, actually has one.
#------------------------------------------------------------------------------
- if ($arg eq "--version")
- {
- print_version_info ();
- exit (0);
- }
- elsif ($arg eq "--help")
+ GetOptions (
+ "verbose|v:s" => \@opt_verbose,
+ "debug|d:s" => \@opt_debug,
+ "warnings|w:s" => \@opt_warnings,
+ "nowarnings:s" => \@opt_nowarnings,
+ "quiet|q:s" => \@opt_quiet,
+ "output|o=s" => \@opt_output,
+ "overwrite|O=s" => \@opt_overwrite,
+ "highlight-percentage=s" => \@opt_highlight_percentage,
+ "hp=s" => \@opt_obsoleted_hp
+ );
+
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Handle the user input and where needed, generate warnings. In a later stage
+# we check for (cross option) errors and warnings.
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# The very first thing to do is to determine if the user has enabled one of the
+# following options and take action accordingly:
+# --quiet, --verbose, --debug, --warnings
+#
+# We first need to check for quiet mode to be set. If so, all messages need to
+# be silenced, regardless of the settings for verbose, debug, and warnings.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# The quiet option.
+#------------------------------------------------------------------------------
+ if (@opt_quiet)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "quiet";
+ $option_name = "--quiet";
+
+ my ($valid_ref) = extract_option_value (\@opt_quiet,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+
+ $valid = ${ $valid_ref };
+
+ if ($valid)
{
- $ignore_value = print_help_info ();
- exit (0);
+ $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ?
+ $TRUE : $FALSE;
}
- elsif (($arg eq "-v") or ($arg eq "--verbose"))
+ }
+
+#------------------------------------------------------------------------------
+# The debug option.
+#------------------------------------------------------------------------------
+ if (@opt_debug)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "debug";
+ $option_name = "-d/--debug";
+
+ my ($valid_ref) = extract_option_value (\@opt_debug,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+
+ $valid = ${ $valid_ref };
+
+ if ($valid)
+#------------------------------------------------------------------------------
+# Set the appropriate debug size (e.g. "XL") in a table that is used in the
+# gp_message() subroutine.
+#------------------------------------------------------------------------------
{
- $verbose_value = shift @ARGV;
- $valid = check_user_option ("verbose", $verbose_value);
- if (not $valid)
- {
- $option_errors++;
- }
- else
- {
- $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- }
- next;
+ $g_debug = $TRUE;
+ $ignore_value = set_debug_size ();
}
- elsif (($arg eq "-w") or ($arg eq "--warnings"))
+ }
+
+#------------------------------------------------------------------------------
+# The verbose option.
+#------------------------------------------------------------------------------
+ if (@opt_verbose)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "verbose";
+ $option_name = "--verbose";
+
+ my ($valid_ref) = extract_option_value (\@opt_verbose,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+ $valid = ${ $valid_ref };
+
+ if ($valid)
{
- my $warnings_value = shift @ARGV;
- $valid = check_user_option ("warnings", $warnings_value);
- if (not $valid)
- {
- $option_errors++;
- }
- else
- {
- $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- }
- next;
+ $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ?
+ $TRUE : $FALSE;
}
- elsif (($arg eq "-d") or ($arg eq "--debug"))
- {
- $debug_value = shift @ARGV;
- $valid = check_user_option ("debug", $debug_value);
- if (not $valid)
- {
- $option_errors++;
- }
- else
- {
+ }
+
#------------------------------------------------------------------------------
-# This function internally converts the value to uppercase.
+# The nowarnings option.
#------------------------------------------------------------------------------
- my $ignore_value = set_debug_size (\$debug_value);
- }
- next;
- }
- elsif (($arg eq "-q") or ($arg eq "--quiet"))
- {
- $quiet_value = shift @ARGV;
- $valid = check_user_option ("quiet", $quiet_value);
+ if (@opt_nowarnings)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "nowarnings";
+ $option_name = "--nowarnings";
- if (not $valid)
- {
- $option_errors++;
- }
- else
- {
- $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- }
- next;
- }
- elsif (($arg eq "-o") or ($arg eq "--output"))
- {
- $outputdir_value = shift @ARGV;
- $valid = check_user_option ("output", $outputdir_value);
+ my ($valid_ref) = extract_option_value (\@opt_nowarnings,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
- if (not $valid)
- {
- $option_errors++;
- }
+ $valid = ${ $valid_ref };
- next;
- }
- elsif (($arg eq "-O") or ($arg eq "--overwrite"))
+ if ($valid)
{
- $outputdir_value = shift @ARGV;
- $valid = check_user_option ("overwrite", $outputdir_value);
+ $g_warnings =
+ $g_user_settings{"nowarnings"}{"current_value"} eq "on" ?
+ $FALSE : $TRUE;
+ }
+ }
- if (not $valid)
- {
- $option_errors++;
- }
+#------------------------------------------------------------------------------
+# The warnings option (deprecated).
+#------------------------------------------------------------------------------
+ if (@opt_warnings)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "warnings";
+ $option_name = "--warnings";
- next;
- }
- elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage"))
- {
- $hp_value = shift @ARGV;
- $valid = check_user_option ("highlight_percentage", $hp_value);
+ my ($valid_ref) = extract_option_value (\@opt_warnings,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+ }
- if (not $valid)
- {
- $option_errors++;
- }
+#------------------------------------------------------------------------------
+# At this point, the debug, verbose, warnings and quiet settings are known.
+# This subroutine makes the final decision on these settings. For example, if
+# quiet mode has been specified, the settings for debug, verbose and warnings
+# are ignored.
+#------------------------------------------------------------------------------
+ $ignore_value = finalize_special_options ();
- next;
- }
-# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit"))
-# Temporarily disabled {
-# Temporarily disabled $func_limit_value = shift @ARGV;
-# Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value);
-# Temporarily disabled
-# Temporarily disabled if (not $valid)
-# Temporarily disabled {
-# Temporarily disabled $option_errors++;
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled next;
-# Temporarily disabled }
-# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree"))
-# Temporarily disabled {
-# Temporarily disabled $calltree_value = shift @ARGV;
-# Temporarily disabled $valid = check_user_option ("calltree", $calltree_value);
-# Temporarily disabled
-# Temporarily disabled if (not $valid)
-# Temporarily disabled {
-# Temporarily disabled $option_errors++;
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled next;
-# Temporarily disabled }
-# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage"))
-# Temporarily disabled {
-# Temporarily disabled $tp_value = shift @ARGV;
-# Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value);
-# Temporarily disabled
-# Temporarily disabled if (not $valid)
-# Temporarily disabled {
-# Temporarily disabled $option_errors++;
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled next;
-# Temporarily disabled }
-# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics"))
-# Temporarily disabled {
-# Temporarily disabled $default_metrics_value = shift @ARGV;
-# Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value);
-# Temporarily disabled
-# Temporarily disabled if (not $valid)
-# Temporarily disabled {
-# Temporarily disabled $option_errors++;
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled next;
-# Temporarily disabled }
-# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics"))
-# Temporarily disabled {
-# Temporarily disabled $ignore_metrics_value = shift @ARGV;
-# Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value);
-# Temporarily disabled
-# Temporarily disabled if (not $valid)
-# Temporarily disabled {
-# Temporarily disabled $option_errors++;
-# Temporarily disabled }
-# Temporarily disabled
-# Temporarily disabled next;
-# Temporarily disabled }
- else
- {
-
#------------------------------------------------------------------------------
-# When we get to this part of the code it means that the current command line
-# argument is not a known option.
-#
-# We check if it is the name of an experiment directory and if so, add it to
-# the list with directories to use.
-#
-# If not, print an error message and increment the error variable because this
-# is clearly something that is not right.
-#-------------------------------------------------------------------------------
+# A this point we know we can start printing messages in case verbose and/or
+# debug mode have been set.
+#------------------------------------------------------------------------------
+ $msg = "the original command line options: " . join (", ", @CopyOfARGV);
+ gp_message ("debug", $subr_name, $msg);
- if ($arg =~ /^\-.*/)
- {
-#-------------------------------------------------------------------------------
-# It is an option, but not a supported one. Print a message and increment
-# the error count.
-#-------------------------------------------------------------------------------
- $message = "option $arg is not a known option";
- push (@g_user_input_errors, $message);
+ $msg = "the command line options after the special options: " .
+ join (", ", @ARGV);
+ gp_message ("debug", $subr_name, $msg);
- $option_errors++;
- }
- else
- {
-#-------------------------------------------------------------------------------
-# Other than options, the input has to consist of at least one directory name.
-# First remove any trailing slashes (/) and then check if the name is valid.
-#-------------------------------------------------------------------------------
- $arg =~ s/\/*\/$//;
- if ($arg =~ /.+\.er$/)
- {
-#-------------------------------------------------------------------------------
-# It is the name of an experiment directory and is added to the list.
-#-------------------------------------------------------------------------------
- $found_exp_dir = $TRUE;
- push (@exp_dir_list, $arg);
- }
- else
- {
-#-------------------------------------------------------------------------------
-# It is not a valid experiment directory name. Print a message and exit.
-#-------------------------------------------------------------------------------
- $message = "not a valid experiment directory name: $arg";
- push (@g_user_input_errors, $message);
+ gp_message ("verbose", $subr_name, "Parsing the user options");
- $option_errors++;
- }
- }
+#------------------------------------------------------------------------------
+# The output option.
+#------------------------------------------------------------------------------
+ if (@opt_output)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "output";
+ $option_name = "-o/--output";
- } #-- End of last else
+ my ($valid_ref) = extract_option_value (\@opt_output,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+ }
- } #-- End of while-loop
+#------------------------------------------------------------------------------
+# The overwrite option.
+#------------------------------------------------------------------------------
+ if (@opt_overwrite)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "overwrite";
+ $option_name = "-O/--overwrite";
+
+ my ($valid_ref) = extract_option_value (\@opt_overwrite,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+ }
+
+#------------------------------------------------------------------------------
+# The highlight-percentage option.
+#------------------------------------------------------------------------------
+ if (@opt_highlight_percentage)
+ {
+ $max_occurrences = 1;
+ $internal_option_name = "highlight_percentage";
+ $option_name = "--highlight-percentage";
+
+ my ($valid_ref) = extract_option_value (\@opt_highlight_percentage,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
+ }
-#-------------------------------------------------------------------------------
-# Check if the name of the experiment directories is valid. Note that later
-# we check for these directories to exist.
-#-------------------------------------------------------------------------------
- if (not $found_exp_dir)
+#------------------------------------------------------------------------------
+# The hp option (deprecated)
+#------------------------------------------------------------------------------
+ if (@opt_obsoleted_hp)
{
- $message = "experiment directory name(s) are either not valid, or missing";
- push (@g_user_input_errors, $message);
+ $max_occurrences = 1;
+ $internal_option_name = "hp";
+ $option_name = "-hp";
- $option_errors++;
+ my ($valid_ref) = extract_option_value (\@opt_obsoleted_hp,
+ \$max_occurrences,
+ \$internal_option_name,
+ \$option_name);
}
#------------------------------------------------------------------------------
-# Check for fatal errors to have occurred. If so, stop execution. Otherwise,
-# confirm the verbose setting.
+# By now, all options given on the command line have been processed and the
+# list with experiment directories is known.
+#
+# Process the remainder of ARGV, but other than the option generated by the
+# driver, ARGV should be empty.
+#------------------------------------------------------------------------------
+ $ignore_value = wrap_up_user_options ();
+
+# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit"))
+# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree"))
+# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage"))
+# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics"))
+# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics"))
+
+ if (@exp_dir_list)
+#------------------------------------------------------------------------------
+# Print the list of the experiment directories found.
+#
+# Note that later we also check for these directories to actually exist
+# and be valid experiments..
#------------------------------------------------------------------------------
- if ($option_errors > 0)
{
- gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found");
+ $found_exp_dir = $TRUE;
+ $msg = "the following experiment directories will be used:";
+ gp_message ("debug", $subr_name, $msg);
+ for my $i (keys @exp_dir_list)
+ {
+ my $msg = "exp_dir_list[$i] = $exp_dir_list[$i]";
+ gp_message ("debug", $subr_name, $msg);
+ }
}
else
+#------------------------------------------------------------------------------
+# Print a message if the experiment list is not valid, or empty. There will
+# also be error messages in the buffer. These will be printed later.
+#------------------------------------------------------------------------------
{
- gp_message ("debug", $subr_name, "no errors in the options found");
+ $msg = "experiment directory name(s) are either not valid, or missing";
+ gp_message ("debug", $subr_name, $msg);
}
- return ($option_errors, $found_exp_dir, \@exp_dir_list);
+ return (\$found_exp_dir, \@exp_dir_list);
} #-- End of subroutine parse_and_check_user_options
{
my $subr_name = get_my_name ();
- my ($number_of_metrics_ref, $function_info_ref,
- $function_address_and_index_ref, $input_string_ref,
+ my ($number_of_metrics_ref, $function_info_ref,
+ $function_address_and_index_ref, $input_string_ref,
$addressobj_index_ref) = @_;
#------------------------------------------------------------------------------
-# Note that $function_address_and_index_ref is not used, but we need to pass
+# Note that $function_address_and_index_ref is not used, but we need to pass
# in the address into generate_dis_html.
#------------------------------------------------------------------------------
my $number_of_metrics = ${ $number_of_metrics_ref };
my $dis_filename_id_regex = 'file\.([0-9]+)\.dis';
my $filename;
+ my $msg;
my $outputdir = append_forward_slash ($input_string);
my @source_line = ();
- my $source_line_ref;
+ my $source_line_ref;
my @metric = ();
my $metric_ref;
my $target_function;
-
+
gp_message ("debug", $subr_name, "building disassembly files");
gp_message ("debug", $subr_name, "outputdir = $outputdir");
gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id");
}
}
-
+
$filename = $_;
gp_message ("verbose", $subr_name, " Processing disassembly file $filename");
($source_line_ref, $metric_ref) = generate_dis_html (
\$target_function,
- \$number_of_metrics,
- $function_info_ref,
- $function_address_and_index_ref,
- \$outputdir,
- \$filename,
- \@source_line,
- \@metric,
+ \$number_of_metrics,
+ $function_info_ref,
+ $function_address_and_index_ref,
+ \$outputdir,
+ \$filename,
+ \@source_line,
+ \@metric,
\%addressobj_index);
@source_line = @{ $source_line_ref };
- @metric = @{ $metric_ref };
+
+#------------------------------------------------------------------------------
+# TBD. This part needs work. The return variables from generate_dis_html ()
+# are not used, so the code below is meaningless, but awaiting a true fix,
+# the problem which appears on aarch64 is bypassed.
+#------------------------------------------------------------------------------
+ if (defined ($metric_ref))
+ {
+ @metric = @{ $metric_ref };
+ }
+ else
+ {
+ $msg = "metric_ref after generate_dis_html is undefined";
+ gp_message ("debug", $subr_name, $msg);
+ }
}
-
+
return (0)
} #-- End of subroutine parse_dis_files
gp_message ("debug", $subr_name, "processing source file: $_");
my $found_target = process_source (
- $number_of_metrics,
- $function_info_ref,
- $outputdir_with_slash,
+ $number_of_metrics,
+ $function_info_ref,
+ $outputdir_with_slash,
$_);
if (not $found_target)
gp_message ("debug", $subr_name, "target_string on entry = $target_string");
- $target_string =~ s/\(/\\\(/g;
- $target_string =~ s/\)/\\\)/g;
- $target_string =~ s/\+/\\\+/g;
- $target_string =~ s/\[/\\\[/g;
- $target_string =~ s/\]/\\\]/g;
- $target_string =~ s/\*/\\\*/g;
- $target_string =~ s/\./\\\./g;
- $target_string =~ s/\$/\\\$/g;
- $target_string =~ s/\^/\\\^/g;
- $target_string =~ s/\#/\\\#/g;
+ $target_string =~ s/\(/\\\(/g;
+ $target_string =~ s/\)/\\\)/g;
+ $target_string =~ s/\+/\\\+/g;
+ $target_string =~ s/\[/\\\[/g;
+ $target_string =~ s/\]/\\\]/g;
+ $target_string =~ s/\*/\\\*/g;
+ $target_string =~ s/\./\\\./g;
+ $target_string =~ s/\$/\\\$/g;
+ $target_string =~ s/\^/\\\^/g;
+ $target_string =~ s/\#/\\\#/g;
gp_message ("debug", $subr_name, "target_string on return = $target_string");
my $outputdir = append_forward_slash ($input_string);
my @sort_fields = @{ $sort_fields_ref };
-
- my $error_code;
+
+ my $error_code;
my $cmd_output;
my $re;
} #-- End of subroutine preprocess_function_files
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Print the original list with the command line options.
+#------------------------------------------------------------------------------
+sub print_command_line_options
+{
+ my ($identifier_ref) = @_;
+
+ my $identifier = ${ $identifier_ref };
+ my $msg;
+
+ $msg = "The command line options (shown for ease of reference): ";
+ printf ("%-9s %s\n", $identifier, ucfirst ($msg));
+
+ $msg = join (", ", @CopyOfARGV);
+ printf ("%-9s %s\n", $identifier, $msg);
+
+# printf ("%-9s\n", $identifier);
+
+ return (0);
+
+} #-- End of subroutine print_command_line_options
+
+#------------------------------------------------------------------------------
+# Print all the errors messages in the buffer.
+#------------------------------------------------------------------------------
+sub print_errors_buffer
+{
+ my $subr_name = get_my_name ();
+
+ my ($identifier_ref) = @_;
+
+ my $ignore_value;
+ my $msg;
+ my $plural_or_single;
+ my $identifier = ${ $identifier_ref };
+
+ $plural_or_single = ($g_total_error_count > 1) ? "errors have" : "error has";
+
+ if (@g_warning_msgs and $g_warnings)
+#------------------------------------------------------------------------------
+# Make sure that all warnings are printed in case of an error. This is to
+# avoid that warnings get lost in case the program terminates early.
+#------------------------------------------------------------------------------
+ {
+ $ignore_value = print_warnings_buffer ();
+ }
+
+ if (not $g_options_printed)
+#------------------------------------------------------------------------------
+# The options are printed as part of the warnings, so only if the warnings are
+# not printed, we need to print them in case of errors.
+#------------------------------------------------------------------------------
+ {
+ $g_options_printed = $TRUE;
+ $ignore_value = print_command_line_options (\$identifier);
+ }
+
+ $msg = "a total of " . $g_total_error_count;
+ $msg .= " fatal " . $plural_or_single . " been detected:";
+ printf ("%-9s %s\n", $identifier, ucfirst ($msg));
+
+ for my $key (keys @g_error_msgs)
+ {
+ $msg = $g_error_msgs[$key];
+ printf ("%-11s %s\n", $identifier, ucfirst ($msg));
+ }
+
+ return (0);
+
+} #-- End of subroutine print_errors_buffer
+
+#------------------------------------------------------------------------------
# Print the help overview
-#-------------------------------------------------------------------------------
-sub print_help_info
+#------------------------------------------------------------------------------
+sub print_help_info
{
- print
- #-------Marker line - do not go beyond this line ------------------------------
- "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n".
- "\n".
- "Process one or more experiments to generate a directory containing the\n" .
- "index.html file that may be used to browse the experiment data.\n".
- "\n".
- "Options:\n".
- "\n".
- " --help print usage information and exit.\n".
- " --version print the version number and exit.\n".
- " --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" .
- " messages about the processing of the data; default\n" .
- " is off.\n".
- #-------Marker line - do not go beyond this line ------------------------------
- " -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" .
- " to assist with troubleshooting, or further\n" .
- " development of this tool; on gives a modest amount\n" .
- " of information; s, m, l, or xl gives an increasing\n" .
- " amount of information and off disables the printing\n" .
- " of debug information; note that currently on, s, m,\n" .
- " and l are equivalent; this is expected to change in\n" .
- " future updates; default is off.\n" .
- #-------Marker line - do not go beyond this line ------------------------------
- " -hp, ----highlight-percentage <value> a percentage value in the interval\n" .
- " [0,100] to select and color code source\n" .
- " lines as well as instructions that are\n" .
- " within this percentage of the maximum\n" .
- " metric value(s); a value of zero (-hp 0)\n" .
- " disables this feature; the default is 90.\n".
- #-------Marker line - do not go beyond this line ------------------------------
- " -o, --output <dir-name> use <dir-name> to store the results in; the\n" .
- " default name is ./display.<n>.html with <n> the\n" .
- " first positive integer number not in use; an\n" .
- " existing directory is not overwritten.\n".
- #-------Marker line - do not go beyond this line ------------------------------
- " -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" .
- " overwrite any existing directory with the\n" .
- " same name; make sure that umask is set to the\n" .
- " correct access permissions.\n" .
- #-------Marker line - do not go beyond this line ------------------------------
- " -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" .
- " verbose messages; if set to on, the settings for\n" .
- " verbose, warnings and debug are ignored; default\n" .
- " is off.\n".
- #-------Marker line - do not go beyond this line ------------------------------
- " -w, --warnings {on|off} enable/disable run time warning messages;\n" .
- " default is on.\n".
- "\n".
-# Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n".
-# Temmporarily disabled " this is an integer number; set to 0 to process all\n".
-# Temmporarily disabled " functions; the default value is 100.\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n".
-# Temmporarily disabled " from the bottom of the first page; default is off.\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n".
-# Temmporarily disabled " inclusion of functions for each metric will take\n".
-# Temmporarily disabled " place in sort order until the percentage has been\n".
-# Temmporarily disabled " reached.\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n".
-# Temmporarily disabled " and use a default set of metrics; the default is off.\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled "Environment:\n".
-# Temmporarily disabled "\n".
-# Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n".
-# Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n".
-# Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n".
-# Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n".
-# Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n".
-# Temmporarily disabled "\n".
- "Documentation:\n".
- "\n".
- "A getting started guide for gprofng is maintained as a Texinfo manual.\n" .
- "If the info and gprofng programs are properly installed at your site,\n" .
- "the command \"info gprofng\" should give you access to this document.\n".
- "\n".
- "See also:\n".
- "\n".
- "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " .
- "gp-display-text(1)\n";
-
- return (0);
+ my $space = " ";
+
+ printf("%s\n",
+ "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)");
+ printf("\n");
+ printf("%s\n",
+ "Process one or more experiments to generate a directory containing the");
+ printf("%s\n",
+ "index.html file that may be used to browse the experiment data.");
+ printf("\n");
+ printf("%s\n",
+ "Options:");
+ printf("\n");
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("--help",
+ "Print usage information and exit.");
+
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("--version",
+ "Print the version number and exit.");
+
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("--verbose",
+ "Enable verbose mode to show diagnostic messages about the");
+ print_help_line ("",
+ "processing of the data. By default verbose mode is disabled.");
+
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("-d [<db-vol-size>], --debug[=<db-vol-size>]",
+ "Control the printing of run time debug information to assist with");
+ print_help_line ("",
+ "the troubleshooting, or further development of this tool.");
+ print_help_line ("",
+ "The <db-vol-size> parameter controls the output volume and is");
+ print_help_line ("",
+ "one from the list {s | S | m | M | l | L | xl | XL}.");
+ print_help_line ("",
+ "If db-vol-size is not specified, a modest amount of information");
+ print_help_line ("",
+ "is printed. This is equivalent to select size s, or S. The");
+ print_help_line ("",
+ "volume of data goes up as the size increases. Note that");
+ print_help_line ("",
+ "currently l/L is equivalent to xl/XL, but this is expected to");
+ print_help_line ("",
+ "change in future updates. By default debug mode is disabled.");
+
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("--highlight-percentage=<value>",
+ "A percentage value in the interval [0,100] to select and color");
+ print_help_line ("",
+ "code source lines, as well as instructions, that are within this");
+ print_help_line ("",
+ "percentage of the maximum metric value(s). A value of zero");
+ print_help_line ("",
+ "disables this feature. The default value is 90 (%).");
+
+ #-------Marker line - do not go beyond this line ----------------------------
+ print_help_line ("-o <dirname>, --output=<dirname>",
+ "Use <dirname> as the directory name to store the results in.");
+ print_help_line ("",
+ "In absence of this option, the default name is display.<n>.html.");
+ print_help_line ("",
+ "This directory is created in the current directory. The number");
+ print_help_line ("",
+ "<n> is the first positive integer number not in use in this");
+ print_help_line ("",
+ "naming scheme. An existing directory with the same name is not");
+ print_help_line ("",
+ "overwritten. Make sure that umask is set to the correct access");
+ print_help_line ("",
+ "permissions.");
+
+ #-------Marker line - do not go beyond this line --------------------------
+ print_help_line ("-O <dirname>, --overwrite=<dirname>",
+ "Use <dirname> as the directory name to store the results in.");
+ print_help_line ("",
+ "In absence of this option, the default name is display.<n>.html.");
+ print_help_line ("",
+ "This directory is created in the current directory. The number");
+ print_help_line ("",
+ "<n> is the first positive integer number not in use in this");
+ print_help_line ("",
+ "naming scheme. An existing directory with the same name is");
+ print_help_line ("",
+ "silently overwritten. Make sure that umask is set to the");
+ print_help_line ("",
+ "correct access permissions.");
+
+ #-------Marker line - do not go beyond this line --------------------------
+ print_help_line ("-q, --quiet",
+ "Disable the display of all warning, debug, verbose and any");
+ print_help_line ("",
+ "other messages. If enabled, the settings for verbose and debug");
+ print_help_line ("",
+ "are accepted, but ignored. With this option, there is no screen");
+ print_help_line ("",
+ "output, other than errors. By default quiet mode is disabled");
+
+ #-------Marker line - do not go beyond this line --------------------------
+ print_help_line ("--nowarnings",
+ "Disable the printing of warning messages on stdout. By default");
+ print_help_line ("",
+ "warning messages are printed.");
+
+ #-------Marker line - do not go beyond this line --------------------------
+ printf("\n");
+ printf ("%s\n","Report bugs to <https://sourceware.org/bugzilla/>");
+
+ return (0);
} #-- End of subroutine print_help_info
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Print a single line as part of the help output.
+#
+# If the first item is not the empty string, it is considered to be the
+# option. If the length of the option exceeds the limit set by $max_space,
+# it is printed by itself and the text is printed on the next line. Otherwise
+# the text follows the option.
+#
+# To assist with the development of the help text, we check if the total length
+# of the line exceeds the max numbers of columns (79 according to the GNU
+# coding standards).
+#------------------------------------------------------------------------------
+sub print_help_line
+{
+ my $subr_name = get_my_name ();
+
+ my ($item, $help_text) = @_;
+
+ my $length_item = length ($item);
+ my $max_col = 79;
+ my $max_space = 14;
+ my $no_of_spaces;
+ my $pad;
+ my $space = " ";
+ my $the_message;
+
+ if ($length_item > $max_col)
+ {
+ printf ("Error: $item is $length_item long - exceeds $max_col\n");
+ exit (0);
+ }
+ elsif ( $length_item == 0 )
+ {
+ $no_of_spaces = $max_space;
+
+ $pad = "";
+ for my $i (1..$no_of_spaces)
+ {
+ $pad .= $space;
+ }
+ $the_message = $pad . $help_text;
+ }
+ else
+ {
+ if ($length_item < $max_space)
+ {
+ $no_of_spaces = $max_space - length ($item);
+ $pad = "";
+ for my $i (1..$no_of_spaces)
+ {
+ $pad .= $space;
+ }
+ $the_message = $item . $pad . $help_text;
+ }
+ else
+ {
+ $pad = "";
+ for my $i (1..$max_space)
+ {
+ $pad .= $space;
+ }
+ printf("%s\n", $item);
+ $the_message = $pad . $help_text;
+ }
+ }
+
+ if (length ($the_message) <= $max_col)
+ {
+ printf ("%s\n", $the_message);
+ }
+ else
+ {
+ my $delta = length ($the_message) - $max_col;
+ printf ("%s\n", "$the_message - exceeds $max_col by $delta");
+ exit (0);
+ }
+
+
+ return (0);
+
+} #-- End of subroutine print_help_line
+
+#------------------------------------------------------------------------------
# Print the meta data for each experiment directory.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub print_meta_data_experiments
{
my $subr_name = get_my_name ();
#------------------------------------------------------------------------------
# Brute force subroutine that prints the contents of a structure with function
-# level information. This version is for a top level array structure,
+# level information. This version is for a top level array structure,
# followed by a hash.
#------------------------------------------------------------------------------
sub print_metric_function_array
my ($metric, $struct_type_name, $target_structure_ref) = @_;
- my @target_structure = @{$target_structure_ref};
+ my @target_structure = @{$target_structure_ref};
gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_;
- my %target_structure = %{$target_structure_ref};
+ my %target_structure = %{$target_structure_ref};
gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
gp_message ("assertion", $subr_name, $msg);
}
}
-
+
return (0);
} #-- End of subroutine print_metric_function_hash
#------------------------------------------------------------------------------
# If there are at least two entries, find the last comma and replace it by
-# " and". Note that we know there is at least one comma, so the value
+# " and". Note that we know there is at least one comma, so the value
# returned by rindex () cannot be -1.
#------------------------------------------------------------------------------
if ($no_of_dirs > 1)
}
$msg .= ($time_percentage_multiplier*100.0)."% of the time";
-
+
gp_message ("verbose", $subr_name, $msg);
} #-- End of subroutine print_opening_message
# In case the length of the comment exceeds the length of the dashed line,
# the comment line is allowed to stick out to the right.
#
-# If the length of the comment is less than the dashed line, it is centered
-# relative to the # length of the dashed line.
+# If the length of the comment is less than the dashed line, it is centered
+# relative to the # length of the dashed line.
-# If the length of the comment and this line do not divide, an extra space is
+# If the length of the comment and this line do not divide, an extra space is
# added to the left of the comment.
#
# For example, if the comment is 55 long, there are 5 spaces to be distributed.
-# There will be 3 spaces, followed by the comment.
+# There will be 3 spaces, followed by the comment.
#------------------------------------------------------------------------------
sub print_table_user_settings
{
my ($mode, $comment) = @_;
+ my $data_type;
+ my $debug_size_value = $g_user_settings{"debug"}{"current_value"};
+ my $db_size;
+ my $defined;
+ my $keyword;
my $leftover;
my $padding;
-
- my $keyword;
my $user_option;
- my $defined;
my $value;
- my $data_type;
- my $HEADER_LIMIT = 60;
- my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value");
+ my $HEADER_LIMIT = 79;
+ my $header = sprintf ("%-20s %-22s %8s %s",
+ "keyword", "option", "user set", "internal value");
#------------------------------------------------------------------------------
# Generate the dashed line
{
$padding = 0;
}
-
+
#------------------------------------------------------------------------------
# Generate the first blank part of the line.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Print a line for each option. The list is sorted alphabetically.
#------------------------------------------------------------------------------
- for my $rc_keyword (sort keys %g_user_settings)
+ for my $key (sort keys %g_user_settings)
{
- $keyword = $rc_keyword;
- $user_option = $g_user_settings{$rc_keyword}{"option"};
- $defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set");
- $data_type = $g_user_settings{$rc_keyword}{"data_type"};
+ $keyword = $key;
+ $user_option = $g_user_settings{$key}{"option"};
+ $defined = ($g_user_settings{$key}{"defined"} ? "set" : "not set");
+ $data_type = $g_user_settings{$key}{"data_type"};
- if (defined ($g_user_settings{$rc_keyword}{"current_value"}))
+ if (defined ($g_user_settings{$key}{"current_value"}))
{
- $value = $g_user_settings{$rc_keyword}{"current_value"};
+ $value = $g_user_settings{$key}{"current_value"};
if ($data_type eq "boolean")
{
$value = $value ? "on" : "off";
}
+#------------------------------------------------------------------------------
+# In case of the debug option, we add the "(size)" string to remind the user
+# that this is the size.
+#------------------------------------------------------------------------------
+ if ($key eq "debug")
+ {
+ $db_size = ($debug_size_value eq "on") ? "s" : $debug_size_value;
+ $value = $db_size . " (size)";
+ }
}
else
{
- $value = "undefined";
+ $value = "undefined";
}
- my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value);
+ my $print_line = sprintf ("%-20s %-22s %8s %s",
+ $keyword, $user_option, $defined, $value);
gp_message ($mode, $subr_name, $print_line);
}
} #-- End of subroutine print_table_user_settings
#------------------------------------------------------------------------------
-# Dump the contents of nested hash "g_user_settings". Some simple formatting
+# Dump the contents of nested hash "g_user_settings". Some simple formatting
# is applied to make it easier to distinguish the various values.
#------------------------------------------------------------------------------
sub print_user_settings
my ($mode, $comment) = @_;
- my $keyword_value_pair;
+ my $keyword_value_pair;
gp_message ($mode, $subr_name, $comment);
- for my $rc_keyword (keys %g_user_settings)
+ for my $key (keys %g_user_settings)
{
- my $print_line = sprintf ("%-20s =>", $rc_keyword);
- for my $fields (sort keys %{ $g_user_settings{$rc_keyword} })
+ my $print_line = sprintf ("%-20s =>", $key);
+ for my $fields (sort keys %{ $g_user_settings{$key} })
{
- if (defined ($g_user_settings{$rc_keyword}{$fields}))
+ if (defined ($g_user_settings{$key}{$fields}))
{
- $keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields};
+ $keyword_value_pair = $fields." = ".$g_user_settings{$key}{$fields};
}
else
{
#------------------------------------------------------------------------------
# Print the version number and license information.
#------------------------------------------------------------------------------
-sub print_version_info
+sub print_version_info
{
print "$version_info\n";
print "Copyright (C) 2023 Free Software Foundation, Inc.\n";
} #-- End of subroutine print_version_info
+#------------------------------------------------------------------------------
+# Dump all the warning messages in the buffer.
+#------------------------------------------------------------------------------
+sub print_warnings_buffer
+{
+ my $subr_name = get_my_name ();
+
+ my $ignore_value;
+ my $msg;
+
+ if (not $g_options_printed)
+#------------------------------------------------------------------------------
+# Only if the options have not yet been printed, print them.
+#------------------------------------------------------------------------------
+ {
+ $g_options_printed = $TRUE;
+ $ignore_value = print_command_line_options (\$g_warn_keyword);
+ }
+
+ for my $i (keys @g_warning_msgs)
+ {
+ $msg = $g_warning_msgs[$i];
+ if ($msg =~ /^$g_html_new_line/)
+ {
+ $msg =~ s/$g_html_new_line//;
+ printf ("%-9s\n", $g_warn_keyword);
+ }
+ printf ("%-9s %s\n", $g_warn_keyword, ucfirst ($msg));
+ }
+
+ return (0);
+
+} #-- End of subroutine print_warnings_buffer
+
#------------------------------------------------------------------------------
# Process the call tree input data and generate HTML output.
#------------------------------------------------------------------------------
{
my $subr_name = get_my_name ();
- my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref,
+ my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref,
$input_string) = @_;
my @function_info = @{ $function_info_ref };
my $infile = $outputdir . "calltree";
my $outfile = $outputdir . "calltree.html";
- open (CALL_TREE_IN, "<", $infile)
+ open (CALL_TREE_IN, "<", $infile)
or die ("Not able to open calltree file $infile for reading - '$!'");
gp_message ("debug", $subr_name, "opened file $infile for reading");
- open (CALL_TREE_OUT, ">", $outfile)
+ open (CALL_TREE_OUT, ">", $outfile)
or die ("Not able to open $outfile for writing - '$!'");
gp_message ("debug", $subr_name, "opened file $outfile for writing");
gp_message ("debug", $subr_name, "building calltree file $outfile");
-
+
#------------------------------------------------------------------------------
# The directory name is potentially used below, but since it is a constant,
# we get it here and only once.
my $size_text = "h2";
my $position_text = "center";
my $html_title_header = ${ generate_a_header (
- \$page_title,
- \$size_text,
+ \$page_title,
+ \$size_text,
\$position_text) };
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Get the acknowledgement, return to main link, and final html statements.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $html_home_left = ${ generate_home_link ("left") };
my $html_acknowledgement = ${ create_html_credits () };
my $html_end = ${ terminate_html_document () };
print CALL_TREE_OUT $html_home_right;
print CALL_TREE_OUT $html_title_header;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Print the generated HTML structures here.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
## print CALL_TREE_OUT "$_" for @whatever;
## print CALL_TREE_OUT "<pre>\n";
## print CALL_TREE_OUT "$_\n" for @whatever2;
## print CALL_TREE_OUT "</pre>\n";
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Print the last part of the HTML file.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
print CALL_TREE_OUT $html_home_left;
print CALL_TREE_OUT "<br>\n";
print CALL_TREE_OUT $html_acknowledgement;
} #-- End of subroutine process_calltree
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Process the generated experiment info file(s).
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub process_experiment_info
{
my $subr_name = get_my_name ();
my $sleep_time;
my $sleep_percentage;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Define the regular expressions used to capture the info.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2'
my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\'';
my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)';
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Scan the experiment data and select the info of interest.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
for my $i (sort keys @experiment_data)
{
$exp_id = $experiment_data[$i]{"exp_id"};
my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file";
gp_message ("debug", $subr_name, $msg);
- open (EXPERIMENT_INFO, "<", $exp_data_file)
+ open (EXPERIMENT_INFO, "<", $exp_data_file)
or die ("$subr_name - unable to open file $exp_data_file for reading '$!'");
gp_message ("debug", $subr_name, "opened file $exp_data_file for reading");
chomp (@exp_info = <EXPERIMENT_INFO>);
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Process the info for the current experiment.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
for my $line (0 .. $#exp_info)
{
$input_line = $exp_info[$line];
gp_message ("debugM", $subr_name, "$exp_id => $start_date");
$experiment_data[$i]{"start_date"} = $start_date;
}
- elsif ($input_line =~ /$end_experiment_regex/)
+ elsif ($input_line =~ /$end_experiment_regex/)
{
$end_experiment = $1;
gp_message ("debugM", $subr_name, "$exp_id => $end_experiment");
$experiment_data[$i]{"end_experiment"} = $end_experiment;
}
- elsif ($input_line =~ /$data_collection_duration_regex/)
+ elsif ($input_line =~ /$data_collection_duration_regex/)
{
$data_collection_duration = $1;
gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration");
# Duration (sec.): 1.812
# Total Thread Time (sec.): 1.812
# Average number of Threads: 1.000
-#
+#
# Process Times (sec.):
# User CPU: 1.666 ( 91.9%)
# System CPU: 0.090 ( 5.0%)
# Wait CPU: 0. ( 0. %)
# Sleep: 0.056 ( 3.1%)
#------------------------------------------------------------------------------
- elsif ($input_line =~ /$total_thread_time_regex/)
+ elsif ($input_line =~ /$total_thread_time_regex/)
{
$total_thread_time = $1;
gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time");
$experiment_data[$i]{"total_thread_time"} = $total_thread_time;
}
- elsif ($input_line =~ /$user_cpu_regex/)
+ elsif ($input_line =~ /$user_cpu_regex/)
{
$user_cpu_time = $1;
$user_cpu_percentage = $2;
$experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")";
$experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage;
}
- elsif ($input_line =~ /$system_cpu_regex/)
+ elsif ($input_line =~ /$system_cpu_regex/)
{
$system_cpu_time = $1;
$system_cpu_percentage = $2;
$experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")";
$experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage;
}
- elsif ($input_line =~ /$sleep_regex/)
+ elsif ($input_line =~ /$sleep_regex/)
{
$sleep_time = $1;
$sleep_percentage = $2;
{
my $subr_name = get_my_name ();
- my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier,
- $summary_metrics, $process_all_functions, $elf_loadobjects_found,
- $outputdir, $sort_fields_ref, $function_info_ref,
- $function_address_and_index_ref, $LINUX_vDSO_ref,
- $metric_description_ref, $elf_arch, $base_va_executable,
+ my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier,
+ $summary_metrics, $process_all_functions, $elf_loadobjects_found,
+ $outputdir, $sort_fields_ref, $function_info_ref,
+ $function_address_and_index_ref, $LINUX_vDSO_ref,
+ $metric_description_ref, $elf_arch, $base_va_executable,
$ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
- my $old_fsummary;
+ my $old_fsummary;
my $total_attributed_time;
my $current_attributed_time;
my $value;
my $srcfile;
my $RIN;
my $gp_listings_cmd;
- my $gp_display_text_cmd;
+ my $gp_display_text_cmd;
my $ignore_value;
my $result_file = $outputdir . "gp-listings.out";
gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-");
-
+
# Function_info creates the functions files from the PC ones
# as well as culling PC and metric information
- ($function_address_info_ref,
- $functions_per_metric_first_index_ref,
+ ($function_address_info_ref,
+ $functions_per_metric_first_index_ref,
$functions_per_metric_indexes_ref) = function_info (
- $outputdir,
- $infile,
- $metric,
+ $outputdir,
+ $infile,
+ $metric,
$LINUX_vDSO_ref);
@{$function_address_info{$metric}} = @{$function_address_info_ref};
%{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref};
%{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref};
- $ignore_value = print_metric_function_array ($metric,
- "function_address_info",
+ $ignore_value = print_metric_function_array ($metric,
+ "function_address_info",
\@{$function_address_info{$metric}});
- $ignore_value = print_metric_function_hash ("hash_hash", $metric,
- "functions_per_metric_first_index",
+ $ignore_value = print_metric_function_hash ("hash_hash", $metric,
+ "functions_per_metric_first_index",
\%{$functions_per_metric_first_index{$metric}});
- $ignore_value = print_metric_function_hash ("hash_array", $metric,
- "functions_per_metric_indexes",
+ $ignore_value = print_metric_function_hash ("hash_array", $metric,
+ "functions_per_metric_indexes",
\%{$functions_per_metric_indexes{$metric}});
}
{
get_hdr_info ($outputdir, $outputdir."calltree.sort.func");
}
-
+
gp_message ("debug", $subr_name, "process functions");
my $scriptfile = $outputdir.'gp-script';
for my $metric (@sort_fields)
{
gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}");
-
+
$total_attributed_time = 0;
$current_attributed_time = 0;
-
+
$value = $function_address_info{$metric}[0]{"metric_value"}; # <Total>
if ($convert_to_dot)
{
$value =~ s/$decimal_separator/\./;
}
$total_attributed_time = $value;
-
+
#------------------------------------------------------------------------------
# start at 1 - skipping <Total>
#------------------------------------------------------------------------------
- for my $INDEX (1 .. $#{$function_address_info{$metric}})
+ for my $INDEX (1 .. $#{$function_address_info{$metric}})
{
#------------------------------------------------------------------------------
#Looking to handle at least 99% of the time - or what the user asked for
gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time");
gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)");
- if ($convert_to_dot)
+ if ($convert_to_dot)
{
$value =~ s/$decimal_separator/\./;
}
if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or
- ( ($total_attributed_time == 0) and ($value>0) ) or
- $process_all_functions)
+ ( ($total_attributed_time == 0) and ($value>0) ) or
+ $process_all_functions)
{
$PCA = $function_address_info{$metric}[$INDEX]{"PC Address"};
gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}");
}
- if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and
+ if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and
exists ($function_address_and_index{$routine}{$PCA}))
{
#------------------------------------------------------------------------------
# handled_routines now contains $RI from "first_metric" (?)
#------------------------------------------------------------------------------
- $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1;
+ $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1;
my $description = ${ retrieve_metric_description (\$metric, \%metric_description) };
if ($metric_description{$metric} =~ /Exclusive Total CPU Time/)
{
- $routine_list{$routine} = 1
+ $routine_list{$routine} = 1
}
gp_message ("debugXL", $subr_name, " $routine is candidate");
- }
- else
+ }
+ else
{
die ("internal error for metric $metric and routine $routine");
}
$function_info[$routine_index]{"srcline"} = "";
$address_field = $function_info[$routine_index]{"addressobjtext"};
-## $disfile = "file\.$routine_index\.dis";
+## $disfile = "file\.$routine_index\.dis";
$disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"};
$srcfile = "";
$srcfile = "file\.$routine_index\.src.txt";
#------------------------------------------------------------------------------
-# If the file is unknown, we can disassemble anyway and add disassembly
+# If the file is unknown, we can disassemble anyway and add disassembly
# to the script.
#------------------------------------------------------------------------------
print SCRIPT "# outfile $outputdir"."$disfile\n";
$limit_txt = $func_limit - 1;
}
- $number_of_metrics = scalar (@sort_fields);
+ $number_of_metrics = scalar (@sort_fields);
$n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics";
gp_message ("debugXL", $subr_name, "built function list with $RIN functions");
gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt");
-# add ELF program header offset
+# add ELF program header offset
for my $routine_index (sort {$a <=> $b} keys %handled_routines)
{
$function_info[$routine_index]{"addressobj"} += bigint::hex (
determine_base_va_address (
- $executable_name,
- $base_va_executable,
- $loadobj,
+ $executable_name,
+ $base_va_executable,
+ $loadobj,
$routine));
$addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index;
if ($error_code != 0)
{
- $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
- $error_code,
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
$gp_error_file);
- gp_message ("abort", "execution terminated");
+ gp_message ("abort", $subr_name, "execution terminated");
}
return (\@function_info, \%function_address_info, \%addressobj_index);
#
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
# Functions sorted by metric: Exclusive Total CPU Time
-#
+#
# PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl.
# Total Cycles Instructions Last-Level IPC CPI
# CPU sec. sec. Executed Cache Misses
my %function_view_structure = %{ $function_view_structure_ref };
my $overview_file = ${ $overview_file_ref };
- my $all_metrics;
+ my $all_metrics;
my $decimal_separator = $g_locale_settings{"decimal_separator"};
my $length_of_block;
- my $elements_in_name;
+ my $elements_in_name;
my $full_hex_address;
my $header_line;
my $hex_address;
my $html_line;
my $input_line;
- my $name_regex;
- my $no_of_fields;
+ my $name_regex;
+ my $no_of_fields;
my $metrics_length;
- my $missing_digits;
+ my $missing_digits;
my $remaining_part_header;
- my $routine;
- my $routine_length;
+ my $routine;
+ my $routine_length;
my $scan_header = $FALSE;
my $scan_function_data = $FALSE;
my $string_length;
- my $total_header_lines;
+ my $total_header_lines;
my @address_field = ();
- my @fields = ();
+ my @fields = ();
my @function_data = ();
my @function_names = ();
my @function_view_array = ();
#------------------------------------------------------------------------------
if (is_file_empty ($overview_file))
{
- gp_message ("error", $subr_name, "assertion error: file $overview_file is empty");
+ gp_message ("assertion", $subr_name, "file $overview_file is empty");
}
- open (FUNC_OVERVIEW, "<", $overview_file)
+ open (FUNC_OVERVIEW, "<", $overview_file)
or die ("$subr_name - unable to open file $overview_file for reading '$!'");
gp_message ("debug", $subr_name, "opened file $overview_file for reading");
chomp (@function_data = <FUNC_OVERVIEW>);
gp_message ("debug", $subr_name, "read all of file $overview_file into memory");
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Parse the function view info and store the data.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $max_header_length = 0;
my $max_metrics_length = 0;
{
$scan_header = $TRUE;
}
- elsif ($input_line =~ /$total_marker_regex/)
+ elsif ($input_line =~ /$total_marker_regex/)
{
$scan_header = $FALSE;
$scan_function_data = $TRUE;
if ($scan_header)
{
#------------------------------------------------------------------------------
-# This group is only defined for the first line of the header and $4 contains
+# This group is only defined for the first line of the header and $4 contains
# the remaining part of the line after "Name", without the leading spaces.
#------------------------------------------------------------------------------
if (defined ($4))
gp_message ("debugXL", $subr_name, $msg);
#------------------------------------------------------------------------------
-# Determine the maximum length of the header. This needs to be done before
+# Determine the maximum length of the header. This needs to be done before
# the HTML controls are added.
#------------------------------------------------------------------------------
my $header_length = length ($remaining_part_header);
# Captures the subsequent header lines. Assume they exist.
#------------------------------------------------------------------------------
elsif ($input_line =~ /$catch_all_regex/)
- {
+ {
$header_line = $1;
gp_message ("debugXL", $subr_name, "header_line = $header_line");
gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length");
gp_message ("debugXL", $subr_name, "html_line = $html_line");
- }
+ }
}
#------------------------------------------------------------------------------
# This is a line with function data.
$elements_in_name = $no_of_fields - $number_of_metrics - 1;
gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name");
-
+
#------------------------------------------------------------------------------
# TBD: Handle this better in case a function entry has more than 2 words.
# Build the regex dynamically and use eval to capture the correct group.
# CHECK CODE IN GENERATE_CALLER_CALLEE
#------------------------------------------------------------------------------
- if ($elements_in_name == 1)
+ if ($elements_in_name == 1)
{
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)';
}
- elsif ($elements_in_name == 2)
+ elsif ($elements_in_name == 2)
{
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)';
}
$full_hex_address = $1;
$routine = $2;
- if ($elements_in_name == 1)
+ if ($elements_in_name == 1)
{
$all_metrics = $3;
}
- elsif ($elements_in_name == 2)
+ elsif ($elements_in_name == 2)
{
$all_metrics = $5;
}
#------------------------------------------------------------------------------
-# In case the last metric is 0. only, we append 3 extra characters that
+# In case the last metric is 0. only, we append 3 extra characters that
# represent zero. We cannot change the number to 0.000 though because that
# has a different interpretation than 0.
-# In a later phase, the "ZZZ" symbol will be removed again, but for now it
+# In a later phase, the "ZZZ" symbol will be removed again, but for now it
# creates consistency in, for example, the length of the metrics part.
#------------------------------------------------------------------------------
if ($all_metrics =~ /$zero_dot_at_end_regex/)
#------------------------------------------------------------------------------
my $decimal_point = $decimal_separator;
$decimal_point =~ s/$backward_slash_regex//;
- my $txt = "all_metrics = $all_metrics ended with 0";
+ my $txt = "all_metrics = $all_metrics ended with 0";
$txt .= "$decimal_point ($decimal_separator)";
gp_message ("debugXL", $subr_name, $txt);
}
$metrics_length = length ($all_metrics);
$max_metrics_length = max ($max_metrics_length, $metrics_length);
- gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length");
+ gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length");
if ($full_hex_address =~ /$get_hex_address_regex/)
{
$hex_address = "0x" . $2;
}
- push (@address_field, $hex_address);
+ push (@address_field, $hex_address);
push (@metric_values, $all_metrics);
#------------------------------------------------------------------------------
my @function_index_list = ();
#------------------------------------------------------------------------------
-# First, an index list is built. If we are to index the functions in order of
+# First, an index list is built. If we are to index the functions in order of
# appearance in the function overview from 0 to n-1, the value of the array
# for index "i" is the index into the large "function_info" structure. This
# has the final name, the html function block, etc.
my $current_address = $address_field[$i];
my $found_a_match = $FALSE;
- my $final_function_name;
- my $ref_index;
+ my $final_function_name;
+ my $ref_index;
#------------------------------------------------------------------------------
# Check if there are duplicate entries for this function. If there are, use
# part after the colon and remove the first part.
#------------------------------------------------------------------------------
$addr_offset =~ s/$get_addr_offset_regex//;
-
+
gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index");
gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
if (defined ($g_map_function_to_index{$routine}[0]))
{
$found_a_match = $TRUE;
- $ref_index = $g_map_function_to_index{$routine}[0];
+ $ref_index = $g_map_function_to_index{$routine}[0];
push (@function_index_list, $ref_index);
my $final_function_name = $function_info[$ref_index]{"routine"};
gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name");
}
#------------------------------------------------------------------------------
-# The loop over all function names has completed and @function_index_list
+# The loop over all function names has completed and @function_index_list
# contains the index values into @function_info for the functions.
#
# All we now need to do is to retrieve the correct field(s) from the array.
# be there.
#
# TBD: Check if this can be done only once.
-# ------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my $target_keyword = "Excl.";
($foundit_ref, $index_values_ref) = find_keyword_in_string (
- \$remaining_part_header,
+ \$remaining_part_header,
\$target_keyword);
$foundit = ${ $foundit_ref };
@index_values = @{ $index_values_ref };
- if ($foundit)
+ if ($foundit)
{
for my $i (keys @index_values)
{
gp_message ("assertion", $subr_name, $msg);
}
-# ------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Compute the number of spaces we need to add between the "(sort)" strings.
#
# For example:
# The number of spaces to be added is stored in @padding_values. These are
# the spaces to be added before the occurrence of "(sort)". This is why the
# first padding value is 0.
-# ------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
-# ------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD: This needs to be done only once.
-# ------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
my @padding_values = ();
my $P_previous = 0;
for my $i (keys @index_values)
my $txt = "padding_values[$i] = $padding_values[$i]";
gp_message ("debugXL", $subr_name, $txt);
}
-
+
#------------------------------------------------------------------------------
# Build up the sort line. Mark the current metric and make sure the line is
# aligned with the header.
# The current metric should have a different background color.
#------------------------------------------------------------------------------
{
- $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
- "." . $metric_value . ".html' style='background-color:" .
- $g_html_color_scheme{"background_selected_sort"} .
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ "." . $metric_value . ".html' style='background-color:" .
+ $g_html_color_scheme{"background_selected_sort"} .
"\'><b>(sort)</b></a>";
}
elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric))
#------------------------------------------------------------------------------
-# Set the background color for the sort metric in the main function overview.
+# Set the background color for the sort metric in the main function overview.
#------------------------------------------------------------------------------
{
- $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
- "." . $metric_value . ".html' style='background-color:" .
- $g_html_color_scheme{"background_selected_sort"} .
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ "." . $metric_value . ".html' style='background-color:" .
+ $g_html_color_scheme{"background_selected_sort"} .
"'><b>(sort)</b></a>";
}
else
# Do not set a specific background for all other metrics.
#------------------------------------------------------------------------------
{
- $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
"." . $metric_value . ".html'>(sort)</a>";
}
gp_message ("debugXL", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# Element "function table" contains the array with all the function view data.
+# Element "function table" contains the array with all the function view data.
#------------------------------------------------------------------------------
$function_view_structure{"header"} = [@header_lines];
$function_view_structure{"metrics part"} = [@metrics_part];
my ($html_metrics_record,$imetric,$metric);
$html_metrics_record =
- "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" .
+ "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" .
"<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
"<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n";
$outfile = $outputdir . "metrics.html";
- open (METRICSOUT, ">", $outfile)
+ open (METRICSOUT, ">", $outfile)
or die ("$subr_name - unable to open file $outfile for writing - '$!'");
gp_message ("debug", $subr_name, "opened file $outfile for writing");
# $imetricn = scalar (keys %IMETRICS);
$imetricn = scalar (keys %ignored_metrics);
- if ($imetricn)
+ if ($imetricn)
{
$html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">";
# for $imetric (sort keys %IMETRICS){
} #-- End of subroutine process_metrics
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub process_metrics_data
{
my $subr_name = get_my_name ();
my $metric_name;
my $metric_text;
my $metricdata;
- my $metric_line;
+ my $metric_line;
my $summary_metrics;
my $detail_metrics;
my ($last_metric,$metric,$value,$i,$r);
- open (METRICTOTALS, "<", $outfile2)
+ open (METRICTOTALS, "<", $outfile2)
or die ("Unable to open metric value data file $outfile2 for reading - '$!'");
gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data");
#------------------------------------------------------------------------------
-# Below an example of the file that has just been opened. The lines I marked
+# Below an example of the file that has just been opened. The lines I marked
# with a * has been wrapped by my for readability. This is not the case in the
# file, but makes for a really long line.
#
# Inclusive Instructions Executed: 54417033412 (100.0%)
# Exclusive Last-Level Cache Misses: 252730685 (100.0%)
# Inclusive Last-Level Cache Misses: 252730685 (100.0%)
-# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle:
-# * Exclusive Cycles Per Instruction:
-# * Inclusive Cycles Per Instruction:
+# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle:
+# * Exclusive Cycles Per Instruction:
+# * Inclusive Cycles Per Instruction:
# * Size: 0
# PC Address: 1:0x00000000
# Source File: (unknown)
gp_message ("debug", $subr_name, "file metrictotals: $metricdata");
#------------------------------------------------------------------------------
-# Ignoring whitespace, search for any line with a ":" in it, followed by
+# Ignoring whitespace, search for any line with a ":" in it, followed by
# a number with or without a dot. So, an integer or floating-point number.
#------------------------------------------------------------------------------
if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/)
if (scalar (keys %metric_value) == 0)
#------------------------------------------------------------------------------
-# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we
+# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we
# blow up later.
#
# TBD: See if this can be handled differently.
# The original regex has bugs because the line should not be allowed to start
# with a ":". So this is wrong:
# if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
-#
+#
# This is better:
# if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
#
#------------------------------------------------------------------------------
# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
- ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) =
+ ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) =
extract_metric_specifics ($metric_line);
# if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
{
$user_metrics = $TRUE;
gp_message ("debug", $subr_name, "m: user_metrics set to TRUE");
- }
+ }
elsif ($metric_spec =~ /system/)
- {
+ {
$system_metrics = $TRUE;
gp_message ("debug", $subr_name, "m: system_metrics set to TRUE");
- }
+ }
elsif ($metric_spec =~ /wall/)
{
$wall_metrics = $TRUE;
gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE");
- }
+ }
#------------------------------------------------------------------------------
# TBD I don't see why these need to be skipped. Also, should be totalcpu.
#------------------------------------------------------------------------------
gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1");
$detail_metrics_system = $detail_metrics_system.':'.$metric_spec;
gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1");
- }
+ }
else
{
gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
}
- }
- else
+ }
+ else
{
$summary_metrics = $metric_spec;
gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2");
gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2");
$detail_metrics_system = $metric_spec;
gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2");
- }
- else
+ }
+ else
{
gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
}
}
gp_message ("debug", $subr_name, " metric $metric_spec added");
- }
- else
+ }
+ else
{
gp_message ("debug", $subr_name, "m: no want above metric was a 0 total");
}
- }
+ }
}
}
{
$summary_metrics = "e.user:".$summary_metrics;
}
- else
+ else
{
$summary_metrics = "e.user:i.user:".$summary_metrics;
}
if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
{
$call_metrics = "a.user:".$call_metrics;
- }
- else
+ }
+ else
{
$call_metrics = "a.user:i.user:".$call_metrics;
}
{
my $subr_name = get_my_name ();
- my ($start_scan, $end_scan,
+ my ($start_scan, $end_scan,
$src_times_regex, $function_regex, $number_of_metrics,
$file_contents_ref, $modified_html_ref) = @_;
# Generate straightforward HTML, but define an anchor based on the source line
# number in the list.
#------------------------------------------------------------------------------
- $line_id = extract_source_line_number ($src_times_regex,
- $function_regex,
- $number_of_metrics,
+ $line_id = extract_source_line_number ($src_times_regex,
+ $function_regex,
+ $number_of_metrics,
$input_line);
if ($input_line =~ /$function_regex/)
#------------------------------------------------------------------------------
$modified_line = "<a id=\"line_" . $line_id . "\"></a>";
- my $coloured_line;
+ my $coloured_line;
if ($colour_code_line)
{
my $boldface = $TRUE;
$coloured_line = color_string (
- $input_line,
- $boldface,
+ $input_line,
+ $boldface,
$g_html_color_scheme{"non_target_function_name"});
$colour_code_line = $FALSE;
$modified_line .= "$coloured_line";
#
# Errors are stored during the parsing and processing phase. They are printed
# at the end and sorted by line number.
+#
+#
+# TBD: Does not yet use the warnings/error system. This needs to be fixed.
#------------------------------------------------------------------------------
sub process_rc_file
{
#------------------------------------------------------------------------------
# Local structures.
#------------------------------------------------------------------------------
- my %rc_settings_user = (); #-- Store the values extracted from the config file
+# Stores the values extracted from the config file:
+ my %rc_settings_user = ();
my %error_and_warning_msgs = ();
- my @rc_file_paths = ();
+ my @rc_file_paths = ();
my @split_line;
my @my_fields;
- my $message;
- my $first_part;
+ my $msg;
+ my $first_part;
my $line;
my $line_number;
- my $number_of_fields;
- my $number_of_paths;
+ my $no_of_arguments;
+ my $number_of_fields;
+ my $number_of_paths;
my $parse_errors; #-- Count the number of errors
my $parse_warnings; #-- Count the number of errors
#------------------------------------------------------------------------------
# Check for the presence of a configuration file.
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths");
+ $msg = "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths";
+ gp_message ("debug", $subr_name, $msg);
$rc_file_found = $FALSE;
for my $path_name (@rc_file_paths)
{
$rc_config_file = $path_name . "/" . $rc_file_name;
- gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file");
- if (-f $rc_config_file)
+ $msg = "looking for configuration file " . $rc_config_file;
+ gp_message ("debug", $subr_name, $msg);
+ if (-f $rc_config_file)
{
- gp_message ("debug", $subr_name, "found configuration file $rc_config_file");
+ $msg = "found configuration file " . $rc_config_file;
+ gp_message ("debug", $subr_name, $msg);
$rc_file_found = $TRUE;
last;
}
# There is no configuration file and we can skip this subroutine.
#------------------------------------------------------------------------------
{
- gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found");
+ $msg = "configuration file $rc_file_name not found";
+ gp_message ("verbose", $subr_name, $msg);
return (0);
}
else
{
+ $msg = "unable to open file $rc_config_file for reading:";
open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file")
- or die ("$subr_name - unable to open file $rc_config_file for reading: $!");
+ or die ($subr_name . " - " . $msg . " " . $!);
#------------------------------------------------------------------------------
# The configuration file has been opened for reading.
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading");
+ $msg = "file $rc_config_file has been opened for reading";
+ gp_message ("debug", $subr_name, $msg);
}
- gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file");
- gp_message ("debug", $subr_name, "processing configuration file $rc_config_file");
+ $msg = "found configuration file $rc_config_file";
+ gp_message ("verbose", $subr_name, $msg);
+ $msg = "processing configuration file " . $rc_config_file;
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
# Here we scan the configuration file for the settings.
}
#------------------------------------------------------------------------------
-# Split the input line using the "#" symbol as a separator. We have already
-# handled the case of an isolated comment line, so there may only be an
+# Split the input line using the "#" symbol as a separator. We have already
+# handled the case of an isolated comment line, so there may only be an
# embedded comment.
#
# Regardless of this, we are only interested in the first part.
#------------------------------------------------------------------------------
{
$parse_errors++;
- $message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line";
- $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ $msg = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
next;
}
else
@my_fields = split (/\s/, $split_line[0]);
$number_of_fields = scalar (@my_fields);
- gp_message ("debug", $subr_name, "number of fields = $number_of_fields");
+ $msg = "number of fields = " . $number_of_fields;
+ gp_message ("debug", $subr_name, $msg);
}
- if ($number_of_fields ge 3)
+ if ($number_of_fields ge 3)
#------------------------------------------------------------------------------
# This is not supported.
#------------------------------------------------------------------------------
{
$parse_errors++;
- $message = "more than 2 fields found: $first_part";
- $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ $msg = "more than 2 fields found: $first_part";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
next;
}
elsif ($number_of_fields eq 2)
}
else
{
- my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields";
+ $msg = "[line $line_number] $rc_config_file -";
+ $msg .= " number of fields = $number_of_fields";
gp_message ("assertion", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# Store the keyword, value and line number.
+# Store the keyword, value and line number.
#------------------------------------------------------------------------------
if (exists ($rc_settings_user{$rc_keyword}))
{
my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"};
if ($rc_value ne $prev_value)
{
- $message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'";
+ $msg = "option $rc_keyword previously set at line";
+ $msg .= " $prev_line_number: new value '$rc_value'";
+ $msg .= " ' overrides '$prev_value'";
}
else
{
- $message = "option $rc_keyword previously set to the same value at line $prev_line_number";
+ $msg = "option $rc_keyword previously set to the same value";
+ $msg .= " at line $prev_line_number";
}
- $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message;
+ $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $msg;
}
$rc_settings_user{$rc_keyword}{"value"} = $rc_value;
$rc_settings_user{$rc_keyword}{"line_no"} = $line_number;
- gp_message ("debug", $subr_name, "stored keyword = $rc_keyword");
- gp_message ("debug", $subr_name, "stored value = $rc_value");
- gp_message ("debug", $subr_name, "stored line number = $line_number");
+ gp_message ("debug", $subr_name, "stored keyword = $rc_keyword");
+ gp_message ("debug", $subr_name, "stored value = $rc_value");
+ gp_message ("debug", $subr_name, "stored line number = $line_number");
}
#------------------------------------------------------------------------------
for my $keyword (keys %rc_settings_user)
{
my $key_value = $rc_settings_user{$keyword}{"value"};
- gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value");
+ $msg = "keyword = " . $keyword . " value = " . $key_value;
+ gp_message ("debug", $subr_name, $msg);
}
for my $rc_keyword (keys %g_user_settings)
{
for my $fields (keys %{ $g_user_settings{$rc_keyword} })
{
- gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
+ $msg = "before config file: $rc_keyword $fields =";
+ $msg .= " " . $g_user_settings{$rc_keyword}{$fields};
+ gp_message ("debug", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
-# We are almost done. Check for all keywords found whether they are valid.
+# We are almost done. Check for all keywords found whether they are valid.
# Also verify that the corresponding value is valid.
#
# Update the g_user_settings table if everything is okay.
# - Check how many values it requires (currently exactly one is supported)
# - Is the value a valid number or string?
#------------------------------------------------------------------------------
- my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"};
+ $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"};
if ($no_of_arguments eq 1)
{
#------------------------------------------------------------------------------
{
my $data_type = $g_user_settings{$rc_keyword}{"data_type"};
- my $valid_input = verify_if_input_is_valid ($input_value, $data_type);
+ my $valid_input =
+ verify_if_input_is_valid ($input_value, $data_type);
#------------------------------------------------------------------------------
# Check if the value is valid.
#------------------------------------------------------------------------------
if ($valid_input)
{
- $g_user_settings{$rc_keyword}{"current_value"} = $rc_value;
+ $g_user_settings{$rc_keyword}{"current_value"} =
+ $rc_value;
$g_user_settings{$rc_keyword}{"defined"} = $TRUE;
}
else
{
$parse_errors++;
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
- $message = "input value '$input_value' for keyword $rc_keyword is not valid";
- $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ $msg = "input value '$input_value' for keyword";
+ $msg .= " $rc_keyword is not valid";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"}
+ = $msg;
next;
}
}
{
$parse_errors++;
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
- $message = "missing value for keyword '$rc_keyword'";
- $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ $msg = "missing value for keyword '$rc_keyword'";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"}
+ = $msg;
next;
}
}
{
$parse_errors++;
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
- $message = "keyword $rc_keyword is not supported";
- $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ $msg = "keyword $rc_keyword is not supported";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
}
}
for my $rc_keyword (keys %g_user_settings)
{
for my $fields (keys %{ $g_user_settings{$rc_keyword} })
{
- gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
+ $msg = "after config file: $rc_keyword $fields =";
+ $msg .= " " . $g_user_settings{$rc_keyword}{$fields};
+ gp_message ("debug", $subr_name, $msg);
}
}
print_table_user_settings ("debug", "upon the return from $subr_name");
if ( ($parse_errors == 0) and ($parse_warnings == 0) )
{
- gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file");
+ $msg = "successfully parsed and processed the configuration file";
+ gp_message ("verbose", $subr_name, $msg);
}
else
{
if ($parse_errors > 0)
{
my $plural_or_single = ($parse_errors > 1) ? "errors" : "error";
- $message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:";
- gp_message ("debug", $subr_name, $message);
+ $msg = $g_error_keyword . "found $parse_errors fatal";
+ $msg .= " " . $plural_or_single . " in the configuration file:";
+ gp_message ("debug", $subr_name, $msg);
#------------------------------------------------------------------------------
-# Sort the hash keys, the line numbers, alphabetically and print the
+# Sort the hash keys, the line numbers, alphabetically and print the
# corresponding error messages.
#------------------------------------------------------------------------------
- for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} }))
+ for my $line_no (sort {$a <=> $b}
+ (keys %{ $error_and_warning_msgs{"error"} }))
{
- $message = $g_error_keyword. "[line $line_no] in file $rc_config_file - ";
- $message .= $error_and_warning_msgs{"error"}{$line_no}{"message"};
- gp_message ("debug", $subr_name, $message);
+ $msg = $g_error_keyword . "[line $line_no] in file";
+ $msg .= $rc_config_file . " - ";
+ $msg .= $error_and_warning_msgs{"error"}{$line_no}{"message"};
+ gp_message ("debug", $subr_name, $msg);
}
}
{
if ($parse_warnings > 0)
{
- $message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:";
- gp_message ("debug", $subr_name, $message);
- for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} }))
+ $msg = $g_warn_keyword . " found $parse_warnings warnings in";
+ $msg .= " the configuration file:";
+ gp_message ("debug", $subr_name, $msg);
+ for my $line_no (sort {$a <=> $b}
+ (keys %{ $error_and_warning_msgs{"warning"} }))
{
- $message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - ";
- $message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"};
- gp_message ("debug", $subr_name, $message);
+ $msg = $g_warn_keyword;
+ $msg .= " [line $line_no] in file $rc_config_file - ";
+ $msg .= $error_and_warning_msgs{"warning"}{$line_no}{"message"};
+ gp_message ("debug", $subr_name, $msg);
}
}
}
{
my $subr_name = get_my_name ();
- my ($number_of_metrics, $function_info_ref,
+ my ($number_of_metrics, $function_info_ref,
$outputdir, $input_filename) = @_;
my @function_info = @{ $function_info_ref };
# Computed dynamically below.
# TBD: Try to move this up.
#------------------------------------------------------------------------------
- my $src_times_regex;
- my $hot_lines_regex;
- my $metric_regex;
+ my $src_times_regex;
+ my $hot_lines_regex;
+ my $metric_regex;
my $metric_extra_regex;
- my @components = ();
+ my @components = ();
my @fields_in_line = ();
my @file_contents = ();
my @hot_source_lines = ();
my @modified_html = ();
my @transposed_hot_lines = ();
- my $colour_coded_line;
- my $colour_coded_line_ref;
+ my $colour_coded_line;
+ my $colour_coded_line_ref;
my $line_id;
my $ignore_value;
- my $func_name_in_src_file;
+ my $func_name_in_src_file;
my $html_new_line = "<br>";
- my $input_line;
+ my $input_line;
my $metric_values;
- my $modified_html_ref;
- my $modified_line;
+ my $modified_html_ref;
+ my $modified_line;
my $is_empty;
my $start_all_source;
my $start_target_source;
my $end_target_source;
- my $output_line;
+ my $output_line;
my $hot_line;
my $src_line_no;
- my $src_code_line;
+ my $src_code_line;
my $decimal_separator = $g_locale_settings{"decimal_separator"};
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
-
+
my $file_title;
- my $found_target;
- my $html_dis_record;
- my $html_end;
+ my $found_target;
+ my $html_dis_record;
+ my $html_end;
my $html_header;
- my $html_home;
- my $rounded_percentage;
- my $start_tracking;
- my $threshold_line;
+ my $html_home;
+ my $rounded_percentage;
+ my $start_tracking;
+ my $threshold_line;
my $base;
my $boldface;
my $routine;
my $LANG = $g_locale_settings{"LANG"};
- my $the_title = set_title ($function_info_ref, $input_filename,
+ my $the_title = set_title ($function_info_ref, $input_filename,
"process source");
my $outfile = $input_filename . ".html";
# Remove the .txt from file.<n>.src.txt
#------------------------------------------------------------------------------
my $html_output_file = $input_filename;
- $html_output_file =~ s/$txt_ext_regex/.html/;
+ $html_output_file =~ s/$txt_ext_regex/.html/;
gp_message ("debug", $subr_name, "input_filename = $input_filename");
gp_message ("debug", $subr_name, "the_title = $the_title");
# Open the input file with the source code
#------------------------------------------------------------------------------
{
- open (SRC_LISTING, "<", $input_filename)
+ open (SRC_LISTING, "<", $input_filename)
or die ("$subr_name - unable to open file $input_filename for reading: '$!'");
gp_message ("debug", $subr_name, "opened file $input_filename for reading");
}
# In both cases, the first line after the header has whitespace. This is
# followed by either one of the following:
#
-# - <line_no>.
+# - <line_no>.
# - <Function:
#
# These are the characteristics we use below.
#------------------------------------------------------------------------------
{
$modified_line = "<i>" . $input_line . "</i>";
- push (@modified_html, $modified_line);
+ push (@modified_html, $modified_line);
}
}
#------------------------------------------------------------------------------
gp_message ("debugXL", $subr_name, "found target function $routine");
gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine");
- gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
+ gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
}
}
#------------------------------------------------------------------------------
if (not $found_target)
{
- my $msg;
+ my $msg;
gp_message ("debug", $subr_name, "target function $routine not found");
$msg = "function $routine not found in $base - " .
{
$end_target_source = $#file_contents;
}
- gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
- gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
+ gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
+ gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source");
#------------------------------------------------------------------------------
{
gp_message ("debugXL", $subr_name, " $line_number : found a hot line");
#------------------------------------------------------------------------------
-# We found a hot line and the metric fields are stored in $2. We turn this
+# We found a hot line and the metric fields are stored in $2. We turn this
# string into an array and add it as a row to hot_source_lines.
#------------------------------------------------------------------------------
$hot_line = $1;
#------------------------------------------------------------------------------
for my $row (keys @hot_source_lines)
{
- my $msg = "row[" . $row . "] = ";
+ my $msg = "row[" . $row . "] =";
for my $col (keys @{$hot_source_lines[$row]})
{
- $msg .= "$hot_source_lines[$row][$col] ";
+ $msg .= " $hot_source_lines[$row][$col]";
$transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col];
}
}
#------------------------------------------------------------------------------
for my $row (keys @transposed_hot_lines)
{
- my $msg = "row[" . $row . "] = ";
+ my $msg = "row[" . $row . "] =";
for my $col (keys @{$transposed_hot_lines[$row]})
{
- $msg .= "$transposed_hot_lines[$row][$col] ";
+ $msg .= " $transposed_hot_lines[$row][$col]";
}
gp_message ("debugXL", $subr_name, "hot lines = $msg");
}
#------------------------------------------------------------------------------
# Process those functions that are not the current target.
#------------------------------------------------------------------------------
- $modified_html_ref = process_non_target_source ($start_all_source,
+ $modified_html_ref = process_non_target_source ($start_all_source,
$start_target_source-1,
$src_times_regex,
- $function_regex,
- $number_of_metrics,
+ $function_regex,
+ $number_of_metrics,
\@file_contents,
\@modified_html);
@modified_html = @{ $modified_html_ref };
$routine,
\@max_metric_values,
$src_times_regex,
- $function2_regex,
- $number_of_metrics,
+ $function2_regex,
+ $number_of_metrics,
\@file_contents,
\@modified_html);
@modified_html = @{ $modified_html_ref };
$modified_html_ref = process_non_target_source ($end_target_source+1,
$#file_contents,
$src_times_regex,
- $function_regex,
- $number_of_metrics,
+ $function_regex,
+ $number_of_metrics,
\@file_contents,
\@modified_html);
@modified_html = @{ $modified_html_ref };
#
# TBD: The same is done in generate_dis_html but should be done only once.
#------------------------------------------------------------------------------
- if ($hp_value > 0)
+ if ($hp_value > 0)
{
my $rounded_percentage = sprintf ("%.1f", $hp_value);
- $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
+ $threshold_line = "<i>The setting for the highlight percentage";
+ $threshold_line .= " (--highlight-percentage) option:";
+ $threshold_line .= " " . $rounded_percentage . " (%)</i>";
}
else
{
- $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
+ $threshold_line = "<i>The highlight percentage feature has not been";
+ $threshold_line .= " enabled</i>";
}
$html_home = ${ generate_home_link ("left") };
}
close (NEW_HTML);
close (SRC_LISTING);
-
+
return ($found_target);
} #-- End of subroutine process_source
#------------------------------------------------------------------------------
$input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
- $line_id = extract_source_line_number ($src_times_regex,
- $function2_regex,
- $number_of_metrics,
+ $line_id = extract_source_line_number ($src_times_regex,
+ $function2_regex,
+ $number_of_metrics,
$input_line);
gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id");
gp_message ("debug", $subr_name, "function_name = $2");
my $function_line = "<Function: " . $func_name_in_file . ">";
my $color_function_name = color_string (
- $function_line,
- $boldface,
+ $function_line,
+ $boldface,
$g_html_color_scheme{"target_function_name"});
my $ftag;
if (exists ($g_function_tag_id{$target_function}))
{
@components = split (" ", $input_line, 1+$number_of_metrics+2);
$modified_line = set_background_color_string (
- $input_line,
+ $input_line,
$g_html_color_scheme{"background_color_hot"});
}
else
my $subr_name = get_my_name ();
my ($exp_dir_list_ref) = @_;
-
+
my @exp_dir_list = @{ $exp_dir_list_ref };
my %ignored_metrics = ();
- my $error_code;
- my $message;
+ my $abs_path_dir;
+ my @candidate_ignored_metrics = ();
+ my $error_code;
+ my $hp_value;
+ my $msg;
my $outputdir;
my $target_cmd;
- my $rm_output_msg;
+ my $rm_output_msg;
my $mkdir_output_msg;
- my $time_percentage_multiplier;
+ my $time_percentage_multiplier;
my $process_all_functions;
- my $option_errors = 0;
-
#------------------------------------------------------------------------------
# The -o and -O options are mutually exclusive.
#------------------------------------------------------------------------------
if ($define_new_output_dir and $overwrite_output_dir)
{
- my $msg;
-
$msg = "the -o/--output and -O/--overwrite options are both set, " .
"but are mutually exclusive";
- push (@g_user_input_errors, $msg);
+ gp_message ("error", $subr_name, $msg);
$msg = "(setting for -o = $dir_o_option, " .
"setting for -O = $dir_O_option)";
- push (@g_user_input_errors, $msg);
+ gp_message ("error", $subr_name, $msg);
- $option_errors++;
+ $g_total_error_count++;
}
#------------------------------------------------------------------------------
-# Define the quiet mode. While this is an on/off keyword in the input, we
-# use a boolean in the remainder, because it reads easier.
+# The warnings option is deprecated. Print a warning to this extent and point
+# to the --nowarnings option.
#------------------------------------------------------------------------------
- my $quiet_value = $g_user_settings{"quiet"}{"current_value"};
- $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
-
#------------------------------------------------------------------------------
-# In quiet mode, all verbose, warnings and debug messages are suppressed.
+# Handle the situation that both or one of the highlight-percentage and hp
+# options are set.
#------------------------------------------------------------------------------
- if ($g_quiet)
+ if ($g_user_settings{"warnings"}{"defined"})
{
- $g_user_settings{"verbose"}{"current_value"} = "off";
- $g_user_settings{"warnings"}{"current_value"} = "off";
- $g_user_settings{"debug"}{"current_value"} = "off";
- $g_verbose = $FALSE;
- $g_warnings = $FALSE;
- my $debug_off = "off";
- my $ignore_value = set_debug_size (\$debug_off);
+ $msg = "<br>" . "the --warnings option has been deprecated and";
+ $msg .= " will be ignored";
+ gp_message ("warning", $subr_name, $msg);
+
+ if ($g_user_settings{"nowarnings"}{"defined"})
+ {
+ $msg = "since the --nowarnings option is also used, warnings";
+ $msg .= " are disabled";
+ gp_message ("warning", $subr_name, $msg);
+ }
+ else
+ {
+ $msg = "by default, warnings are enabled and can be disabled with";
+ gp_message ("warning", $subr_name, $msg);
+ $msg = " the --nowarnings option";
+ gp_message ("warning", $subr_name, $msg);
+ }
+ $g_total_warning_count++;
}
- else
- {
+
#------------------------------------------------------------------------------
-# Get the verbose mode.
+# In case both the --highlight-percentage and -hp option are set, issue a
+# warning and continue with the --highlight-percentage value.
#------------------------------------------------------------------------------
- my $verbose_value = $g_user_settings{"verbose"}{"current_value"};
- $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
+ if ($g_user_settings{"hp"}{"defined"})
+ {
+ $msg = "<br>" . "the -hp option has been deprecated and";
+ $msg .= " will be ignored";
+ gp_message ("warning", $subr_name, $msg);
+
+ if ($g_user_settings{"highlight_percentage"}{"defined"})
+ {
+ $msg = "since the --highlight-percentage option is also used,";
+ $msg .= " the value of ";
+ $msg .= $g_user_settings{"highlight_percentage"}{"current_value"};
+ $msg .= " will be applied";
+ gp_message ("warning", $subr_name, $msg);
+ }
+ else
+ {
#------------------------------------------------------------------------------
-# Get the warning mode.
+# If only the -hp option is set, we use it, because we do not want to break
+# compatibility (yet) and force the user to change the option.
#------------------------------------------------------------------------------
- my $warning_value = $g_user_settings{"warnings"}{"current_value"};
- $g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE;
+
+## FUTURE $msg = "instead, the default setting of "
+## FUTURE $msg .= $g_user_settings{"highlight_percentage"}{"current_value"};
+## FUTURE $msg .= " for the --highlight-percentage will be used";
+## FUTURE gp_message ("warning", $subr_name, $msg);
+
+## FUTURE $msg = "please use this option to set the highlighting value";
+## FUTURE gp_message ("warning", $subr_name, $msg);
+
+ $g_user_settings{"highlight_percentage"}{"current_value"} =
+ $g_user_settings{"hp"}{"current_value"};
+
+ $g_user_settings{"highlight_percentage"}{"defined"} = $TRUE;
+
+ $msg = "for now, the value of " .
+ $g_user_settings{"hp"}{"current_value"} .
+ " for the -hp option is used, but please change the" .
+ " option to --highlight-percentage";
+ gp_message ("warning", $subr_name, $msg);
+ }
+
+ $g_total_warning_count++;
}
#------------------------------------------------------------------------------
-# The value for HP should be in the interval (0,100]. We already enforced
+# Regardless of the use of the -hp option, we continue with the value for
+# highlight-percentage. Some more checks are carried out now.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# This value should be in the interval [0,100].
# the number to be positive, but the limits have not been checked yet.
#------------------------------------------------------------------------------
- my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
+ $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
if (($hp_value < 0) or ($hp_value > 100))
{
- my $msg = "the value for the highlight percentage is set to $hp_value, ";
- $msg .= "but must be in the range [0, 100]";
- push (@g_user_input_errors, $msg);
+ $msg = "the value for the highlight percentage is set to $hp_value,";
+ $msg .= " but must be in the range [0, 100]";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+ elsif ($hp_value == 0.0)
+#------------------------------------------------------------------------------
+# A value of zero is interpreted to mean that highlighting should be disabled.
+# To make the checks for this later on easier, set it to an integer value of 0.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{"highlight_percentage"}{"current_value"} = 0;
- $option_errors++;
+ $msg = "reset the highlight percentage value from 0.0 to";
+ $msg .= " " . $g_user_settings{"highlight_percentage"}{"current_value"};
+ gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# The value for TP should be in the interval (0,100]. We already enforced
+# The value for TP should be in the interval (0,100]. We already enforced
# the number to be positive, but the limits have not been checked yet.
#------------------------------------------------------------------------------
my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"};
if (($tp_value < 0) or ($tp_value > 100))
{
- my $msg = "the value for the total percentage is set to $tp_value, " .
- "but must be in the range (0, 100]";
- push (@g_user_input_errors, $message);
+ $msg = "the value for the total percentage is set to $tp_value,";
+ $msg .= " but must be in the range (0, 100]";
+ gp_message ("error", $subr_name, $msg);
- $option_errors++;
+ $g_total_error_count++;
}
else
{
$process_all_functions = $FALSE;
}
- my $txt;
- $txt = "value of time_percentage_multiplier = " .
- $time_percentage_multiplier;
- gp_message ("debugM", $subr_name, $txt);
- $txt = "value of process_all_functions = " .
+ $msg = "value of time_percentage_multiplier = " .
+ $time_percentage_multiplier;
+ gp_message ("debugM", $subr_name, $msg);
+ $msg = "value of process_all_functions = " .
($process_all_functions ? "TRUE" : "FALSE");
- gp_message ("debugM", $subr_name, $txt);
+ gp_message ("debugM", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# to be excluded metrics as an index. The value of $TRUE assigned does not
# really matter.
#------------------------------------------------------------------------------
- my @candidate_ignored_metrics;
-
if ($g_user_settings{"ignore_metrics"}{"defined"})
{
- @candidate_ignored_metrics =
+ @candidate_ignored_metrics =
split (":", $g_user_settings{"ignore_metrics"}{"current_value"});
}
for my $metric (@candidate_ignored_metrics)
}
for my $metric (keys %ignored_metrics)
{
- my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}";
- gp_message ("debugM", $subr_name, $txt);
+ my $msg = "ignored_metrics{$metric} = $ignored_metrics{$metric}";
+ gp_message ("debugM", $subr_name, $msg);
}
#------------------------------------------------------------------------------
-# Check if the experiment directories exist.
+# Check if the experiment directories exist and if they do, add the absolute
+# path. This is easier in the remainder.
#------------------------------------------------------------------------------
for my $i (0 .. $#exp_dir_list)
{
if (-d $exp_dir_list[$i])
{
- my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]);
+ $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]);
$exp_dir_list[$i] = $abs_path_dir;
- my $txt = "directory $exp_dir_list[$i] exists";
- gp_message ("debugM", $subr_name, $txt);
- }
- else
- {
- my $msg = "directory $exp_dir_list[$i] does not exist";
- push (@g_user_input_errors, $msg);
- $option_errors++;
+ $msg = "directory $exp_dir_list[$i] exists";
+ gp_message ("debugM", $subr_name, $msg);
}
}
- return ($option_errors, \%ignored_metrics, $outputdir,
- $time_percentage_multiplier, $process_all_functions,
- \@exp_dir_list);
+ return (\%ignored_metrics, $outputdir, $time_percentage_multiplier,
+ $process_all_functions, \@exp_dir_list);
} #-- End of subroutine process_user_options
#------------------------------------------------------------------------------
# TBD.
#------------------------------------------------------------------------------
-sub rnumerically
+sub rnumerically
{
my ($f1,$f2);
if ($a =~ /^([^\d]*)(\d+)/)
$f2 = int ($2);
$f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1);
}
- }
- else
+ }
+ else
{
return ($b <=> $a);
}
gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
- if ($arch_uname eq "x86_64")
+ if ($arch_uname eq "x86_64")
{
#x86/x64 hardware uses jump
$architecture_supported = $TRUE;
$g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)';
$g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)';
}
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# TBD: Remove the elsif block
-#-------------------------------------------------------------------------------
- elsif ($arch_uname=~m/sparc/s)
+#------------------------------------------------------------------------------
+ elsif ($arch_uname=~m/sparc/s)
{
#sparc hardware uses branch
$architecture_supported = $FALSE;
$g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$';
$g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)';
}
- else
+ else
{
$architecture_supported = $FALSE;
gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality");
$msg = "color = $color input_string = $input_string";
gp_message ("debugXL", $subr_name, $msg);
- $background_color_string = "<span style='background-color: " . $color .
+ $background_color_string = "<span style='background-color: " . $color .
"'>" . $input_string . "</span>";
$msg = "color = $color background_color_string = " .
{
my $subr_name = get_my_name ();
- my ($debug_value_ref) = @_;
-
- my $debug_value = lc (${ $debug_value_ref });
+ my $debug_value = lc ($g_user_settings{"debug"}{"current_value"});
#------------------------------------------------------------------------------
-# Regardless of the value, the debug settings are defined here.
+# Set the corresponding sizes in the table. A value of "on" is equivalent to
+# size "s".
#------------------------------------------------------------------------------
- $g_user_settings{"debug"}{"defined"} = $TRUE;
-
-#------------------------------------------------------------------------------
-# By default, set the value to "on", but correct below if needed.
-#------------------------------------------------------------------------------
- $g_user_settings{"debug"}{"current_value"} = "on";
-
if (($debug_value eq "on") or ($debug_value eq "s"))
{
$g_debug_size{"on"} = $TRUE;
# Any other value is considered to disable debugging.
#------------------------------------------------------------------------------
{
- $g_user_settings{"debug"}{"current_value"} = "off";
+## $g_user_settings{"debug"}{"current_value"} = "off";
+ $g_debug = $FALSE;
$g_debug_size{"on"} = $FALSE;
$g_debug_size{"s"} = $FALSE;
$g_debug_size{"m"} = $FALSE;
#------------------------------------------------------------------------------
# Activate in case of an emergency :-)
#------------------------------------------------------------------------------
-## if ($g_debug_size{$debug_value})
-## {
-## for my $i (keys %g_debug_size)
-## {
-## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n";
-## }
-## }
+ my $show_sizes = $FALSE;
+
+ if ($show_sizes)
+ {
+ if ($g_debug_size{$debug_value})
+ {
+ for my $i (keys %g_debug_size)
+ {
+ print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n";
+ }
+ }
+ }
return (0);
gp_message ("debug", $subr_name,"the value of metric_line = $metric_line");
#------------------------------------------------------------------------------
-# Decode the metric part of the input line. If a valid line, return the
+# Decode the metric part of the input line. If a valid line, return the
# metric components. Otherwise return "skipped" in the metric_spec field.
#------------------------------------------------------------------------------
my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line);
$detail_metrics = $summary_metrics;
$detail_metrics_system = $summary_metrics;
- return (\%metric_description, \%metric_found,
+ return (\%metric_description, \%metric_found,
$summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
} #-- End of subroutine set_default_metrics
#------------------------------------------------------------------------------
# Set various system specific variables. These depend upon both the processor
-# architecture and OS. The values are stored in global structure
+# architecture and OS. The values are stored in global structure
# g_arch_specific_settings.
#------------------------------------------------------------------------------
sub set_system_specific_variables
my $elf_arch;
my $read_elf_cmd;
- my $elf_support;
+ my $elf_support;
my $architecture_supported;
my $arch;
my $regex;
my $subexp;
my $linksubexp;
- if ($arch_uname eq "x86_64")
+ if ($arch_uname eq "x86_64")
{
#------------------------------------------------------------------------------
# x86/x64 hardware uses jump
$g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)';
$g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)';
}
- else
+ else
{
$architecture_supported = $FALSE;
$g_arch_specific_settings{"arch_supported"} = $FALSE;
#------------------------------------------------------------------------------
# TBD Ruud: need to handle this better
#------------------------------------------------------------------------------
- if ($arch_uname_s eq "Linux")
+ if ($arch_uname_s eq "Linux")
{
$elf_arch = $arch_uname_s;
$read_elf_cmd = $g_mapped_cmds{"readelf"};
- if ($read_elf_cmd eq "road_to_nowhere")
+ if ($read_elf_cmd eq "road to nowhere")
{
$elf_support = $FALSE;
}
$elf_support = $TRUE;
}
gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch");
- }
- else
+ }
+ else
{
gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported");
}
my $base;
my $first_line;
+ my $file_is_empty;
my $src_file;
my $RI;
my $the_title;
}
}
$the_title = "Source";
- }
+ }
elsif ($from_where eq "disassembly")
{
if ($base =~ /^file\.(\d+)\.dis$/)
}
}
$the_title = "Disassembly";
- }
- else
+ }
+ else
{
$msg = "called from unknown routine - $from_where";
gp_message ("assertion", $subr_name, $msg);
{
$routine = $function_info[$RI]{"routine"};
}
-
+
if ($from_where eq "process source")
{
- my $is_empty = is_file_empty ($filename);
+ $file_is_empty = is_file_empty ($filename);
- if ($is_empty)
+ if ($file_is_empty)
{
$src_file = "";
}
else
{
- open ($SRC, "<", $filename)
+ open ($SRC, "<", $filename)
or die ("$subr_name - unable to open source file $filename for reading:'$!'");
gp_message ("debug", $subr_name, "opened file $filename for reading");
}
elsif ($from_where eq "disassembly")
{
+ $msg = "unable to open disassembly file $filename for reading:";
open ($DIS, "<", $filename)
- or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
+ or die ($subr_name . " - " . $msg . " " . $!);
gp_message ("debug", $subr_name, "opened file $filename for reading");
- $first_line = <$DIS>;
+ $file_is_empty = is_file_empty ($filename);
+
+ if ($file_is_empty)
+#------------------------------------------------------------------------------
+# Currently, the disassembly file for <static> functions appears to be empty
+# on aarch64. This might be a bug, but it is in any case better to handle
+# this situation.
+#------------------------------------------------------------------------------
+ {
+ $first_line = "";
+ $msg = "file $filename is empty";
+ gp_message ("debugM", $subr_name, $msg);
+ }
+ else
+ {
+ $first_line = <$DIS>;
+ }
+
close ($DIS);
-
+
if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
{
$src_file = "$1"
if ($src_file ne "(unknown)")
{
$the_title .= " ($src_file)";
- }
- else
+ }
+ else
{
$the_title .= " $src_file";
}
} #-- End of subroutine set_title
#------------------------------------------------------------------------------
-# Handles where the output should go. If needed, a directory is # created
-# where the results will go.
+# Handles where the output should go. If needed, a directory to store the
+# results in is created.
#------------------------------------------------------------------------------
sub set_up_output_directory
{
my $subr_name = get_my_name ();
my $error_code;
- my $message;
+ my $msg;
my $mkdir_output_msg;
- my $option_errors;
my $outputdir = "does_not_exist_yet";
my $rm_output_msg;
+ my $success;
my $target_cmd;
my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
- $option_errors = 0;
-
if ((not $define_new_output_dir) and (not $overwrite_output_dir))
#------------------------------------------------------------------------------
-# If neither -o or -O are set, find the next number to be used in the name for
+# If neither -o or -O are set, find the next number to be used in the name for
# the default output directory.
#------------------------------------------------------------------------------
{
my $dir_id = 1;
- while (-d "display.".$dir_id.".html")
+ while (-d "display.".$dir_id.".html")
{ $dir_id++; }
$outputdir = "display.".$dir_id.".html";
}
#------------------------------------------------------------------------------
# The name of the output directory is known and we can proceed.
#------------------------------------------------------------------------------
- gp_message ("debug", $subr_name, "the target output directory is $outputdir");
+ $msg = "the target output directory is $outputdir";
+ gp_message ("debug", $subr_name, $msg);
if (-d $outputdir)
{
#------------------------------------------------------------------------------
if ($define_new_output_dir)
{
- $message = "directory $outputdir already exists";
- $message .= " (use the -O option to overwrite an existing directory)";
- push (@g_user_input_errors, $message);
+ $msg = "directory $outputdir already exists";
+ gp_message ("error", $subr_name, $msg);
+ $msg = "use the -O/--overwite option to overwrite an";
+ $msg .= " existing directory";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
- $option_errors++;
+ gp_message ("abort", $subr_name, $g_abort_msg);
- return ($option_errors, $outputdir);
}
elsif ($overwrite_output_dir)
#------------------------------------------------------------------------------
# It is a bit risky to remove this directory and so we proceed with caution.
# What if the user decides to call it "*" e.g. "-O \*" for example? While this
-# should have been caught when processing the options, we still like to
+# should have been caught when processing the options, we still like to
# be very cautious here before executing /bin/rm -rf.
#------------------------------------------------------------------------------
{
- if ($outputdir eq "*")
+ if ($outputdir eq "*")
{
- $message = "it is not allowed to use * as a value for the -O option";
- push (@g_user_input_errors, $message);
+ $msg = "it is not allowed to use * as a value for the -O option";
+ gp_message ("error", $subr_name, $msg);
- $option_errors++;
+ $g_total_error_count++;
- return ($option_errors, $outputdir);
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
else
{
#------------------------------------------------------------------------------
-# The output directory exists, but it is okay to overwrite it. It is
+# The output directory exists, but it is okay to overwrite it. It is
# removed here and created again below.
#------------------------------------------------------------------------------
$target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir;
if ($error_code != 0)
{
+ $msg = "fatal error when trying to remove $outputdir";
gp_message ("error", $subr_name, $rm_output_msg);
- gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
else
{
- gp_message ("debug", $subr_name, "directory $outputdir has been removed");
+ $msg = "directory $outputdir has been removed";
+ gp_message ("debug", $subr_name, $msg);
}
}
}
} #-- End of if-check for $outputdir
-#-------------------------------------------------------------------------------
-# When we get here, the fatal scenarios have been cleared and the name for
+#------------------------------------------------------------------------------
+# When we get here, the fatal scenarios have not occurred and the name for
# $outputdir is known. Time to create it. Note that recursive creation is
-# supported and umask controls the access permissions.
-#-------------------------------------------------------------------------------
+# supported and the user umask settings control the access permissions.
+#------------------------------------------------------------------------------
$target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir;
($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd);
if ($error_code != 0)
{
- my $msg = "a fatal problem occurred when creating directory $outputdir";
- gp_message ("abort", $subr_name, $msg);
+ $msg = "a fatal problem occurred when creating directory $outputdir";
+ gp_message ("error", $subr_name, $mkdir_output_msg);
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+
+ gp_message ("abort", $subr_name, $g_abort_msg);
}
else
{
- gp_message ("debug", $subr_name, "created output directory $outputdir");
+ $msg = "created output directory $outputdir";
+ gp_message ("debug", $subr_name, $msg);
}
- return ($option_errors, $outputdir);
+ return ($outputdir);
} #-- End of subroutine set_up_output_directory
#------------------------------------------------------------------------------
# Keeps track how many names have been tagged already.
#------------------------------------------------------------------------------
- state $S_total_tagged_names = 0;
+ state $S_total_tagged_names = 0;
+ my $msg;
my $unique_name;
gp_message ("debug", $subr_name, "target_name on entry = $target_name");
#------------------------------------------------------------------------------
# Remove inlining info
#------------------------------------------------------------------------------
- $target_name =~ s/, instructions from source file.*//;
+ $target_name =~ s/, instructions from source file.*//;
if (defined $g_tagged_names{$target_name})
{
- gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}");
- gp_message ("debug", $subr_name, "target_name on return = $target_name");
+ $msg = "target_name = $target_name is already defined: ";
+ $msg .= $g_tagged_names{$target_name};
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "target_name on return = $target_name";
+ gp_message ("debug", $subr_name, $msg);
+
return ($g_tagged_names{$target_name});
}
else
{
$unique_name = "ftag".$S_total_tagged_names;
- $S_total_tagged_names++;
+ $S_total_tagged_names++;
$g_tagged_names{$target_name} = $unique_name;
- gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}");
- gp_message ("debug", $subr_name, "target_name on return = $target_name");
+
+ $msg = "target_name = $target_name is new and added: ";
+ $msg .= "g_tagged_names{$target_name} = $g_tagged_names{$target_name}";
+ gp_message ("debug", $subr_name, $msg);
+
+ $msg = "target_name on return = $target_name";
+ gp_message ("debug", $subr_name, $msg);
+
return ($unique_name);
}
} #-- End of subroutine terminate_html_document
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Perform some basic checks to ensure the input data is consistent. This part
# could be refined and expanded over time. For example by using a checksum
# mechanism to verify the consistency of the executables.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
sub verify_consistency_experiments
{
my $subr_name = get_my_name ();
my $executable_name;
my $full_path_executable_name;
+ my $msg;
my $ref_executable_name;
my $first_exp_dir = $TRUE;
my $count_differences = 0;
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
# Enforce that the full path names to the executable are the same. This could
# be overkill and a checksum approach would be more flexible.
-#-------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
for my $full_exp_dir (@exp_dir_list)
{
my $exp_dir = get_basename ($full_exp_dir);
if ($first_exp_dir)
{
$first_exp_dir = $FALSE;
- $ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
- gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name");
+ $ref_executable_name =
+ $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
+ $msg = "ref_executable_name = " . $ref_executable_name;
+ gp_message ("debug", $subr_name, $msg);
next;
}
- $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
- gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name");
+ $full_path_executable_name =
+ $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
+ $msg = "full_path_executable_name = " . $full_path_executable_name;
+ gp_message ("debug", $subr_name, $msg);
if ($full_path_executable_name ne $ref_executable_name)
{
$count_differences++;
- gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name");
+ $msg = $full_path_executable_name . " does not match";
+ $msg .= " " . $ref_executable_name;
+ gp_message ("debug", $subr_name, $msg);
}
}
#------------------------------------------------------------------------------
# Check if the input item is valid for the data type specified. Validity is
-# verified in the context of gprofng. The definition for the metrics is a
+# verified in the context of gprofng. The definition for the metrics is a
# good example of that.
#------------------------------------------------------------------------------
sub verify_if_input_is_valid
my ($input_item, $data_type) = @_;
+ my $msg;
my $return_value = $FALSE;
#------------------------------------------------------------------------------
}
elsif ($data_type eq "metric_names")
#------------------------------------------------------------------------------
-# A gprofng metric definition but without the flavour and visibility . Either
+# A gprofng metric definition but without the flavour and visibility . Either
# the name consists of "default" only, or a keyword with lowercase letters
# only. This pattern may be repeated with a ":" as the separator.
#------------------------------------------------------------------------------
# This can be almost anything, including "/" and "."
#------------------------------------------------------------------------------
{
- if ($input_item =~ /^[\w\/\.]*$/)
+ if ($input_item =~ /^[\w\/\.\-]*$/)
{
$return_value = $TRUE;
}
}
elsif ($data_type eq "size")
#------------------------------------------------------------------------------
-# Supported values are "on", "off", "s", "m", "l", OR "xl".
+# Supported values are "on", "off", "s", "m", "l", or "xl".
#------------------------------------------------------------------------------
{
if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/)
}
else
{
- my $msg = "the $data_type data type for input $input_item is not supported";
+ $msg = "the $data_type data type for input $input_item is not supported";
gp_message ("assertion", $subr_name, $msg);
- }
+ }
return ($return_value);
} #-- End of subroutine verify_if_input_is_valid
+
+#------------------------------------------------------------------------------
+# Scan the leftovers in ARGV. Other than the option generated by the driver,
+# this list should be empty. Anything left here is considered to be a fatal
+# error and pushed into the g_error_msgs buffer.
+#
+# We use two different arrays for the errors found. This allows us to group
+# the same type of errors.
+#------------------------------------------------------------------------------
+sub wrap_up_user_options
+{
+ my $subr_name = get_my_name ();
+
+ my @opt_unsupported = ();
+ my @opt_ignored = ();
+
+ my $current_option;
+ my $driver_inserted = "--whoami=gprofng display html";
+ my $ignore_option;
+ my $msg;
+ my $option_delimiter = "--";
+
+ if (@ARGV)
+ {
+ $msg = "items in ARGV: " . join (" ", @ARGV);
+ gp_message ("debugXL", $subr_name, $msg);
+
+ $ignore_option = $FALSE;
+ for my $i (keys @ARGV)
+ {
+ $current_option = $ARGV[$i];
+
+ $msg = "ARGV[$i] = $current_option";
+
+ if ($current_option eq $option_delimiter)
+#------------------------------------------------------------------------------
+# The user may use a feature of GetOptions to delimit the options. After
+# this, only experiment names are allowed and these have been handled already,
+# so anything found after this delimite is an error.
+#
+# This is why we set a flag if the delimiter has been found.
+#------------------------------------------------------------------------------
+ {
+ $ignore_option = $TRUE;
+ gp_message ("debugXL", $subr_name, $msg . " (option delimiter)");
+ }
+ elsif ($ignore_option)
+#------------------------------------------------------------------------------
+# We have seen the delimiter, but there are still options, or other strings.
+# In any case, it is not allowed.
+#------------------------------------------------------------------------------
+ {
+ push (@opt_ignored, $current_option);
+ gp_message ("debugXL", $subr_name, $msg . " (ignored)");
+ }
+ elsif ($current_option ne $driver_inserted)
+#------------------------------------------------------------------------------
+# The gprofng driver inserts this and it should be ignored. This is why we
+# only recorded those options different than the one inserted by the driver.
+#------------------------------------------------------------------------------
+ {
+ push (@opt_unsupported, $current_option);
+ gp_message ("debugXL", $subr_name, $msg . " (unsupported)");
+ }
+ else
+#------------------------------------------------------------------------------
+# The gprofng driver inserts this option and it should be ignored.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("debugXL", $subr_name, $msg .
+ " (driver inserted and ignored)");
+ }
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Store any illegal input in the g_error_msgs buffer.
+#------------------------------------------------------------------------------
+ if (@opt_ignored)
+ {
+ $msg = "the following input is out of place:";
+ for my $i (keys @opt_ignored)
+ {
+ $msg .= " " . $opt_ignored[$i];
+ }
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+ if (@opt_unsupported)
+ {
+ $msg = "the following items in the input are not supported:";
+ for my $i (keys @opt_unsupported)
+ {
+ $msg .= " " . $opt_unsupported[$i];
+ }
+ gp_message ("error", $subr_name, $msg);
+
+ $msg = "perhaps an error in the option name, or an option value";
+ $msg .= " is missing?";
+ gp_message ("error", $subr_name, $msg);
+
+ $g_total_error_count++;
+ }
+
+ return (0);
+
+} #-- End of subroutine wrap_up_user_options
projects / thirdparty / binutils-gdb.git / commitdiff
