blob: 306c99a0ec313a4d0087c66fd1c756d3c3d6afd8 [file] [log] [blame]
#!/usr/bin/env perl
# Copyright (C) 2021-2023 Free Software Foundation, Inc.
# Contributed by Oracle.
#
# This file is part of GNU Binutils.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, 51 Franklin Street - Fifth Floor, Boston,
# MA 02110-1301, USA.
use strict;
use warnings;
# Disable before release
# use Perl::Critic;
use bigint;
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.
#------------------------------------------------------------------------------
INIT
{
my $perl_minimal_version_supported = version->parse ("5.10.0")->normal;
my $perl_current_version = version->parse ("$]")->normal;
if ($perl_current_version lt $perl_minimal_version_supported)
{
my $msg;
$msg = "Error: minimum Perl release required: ";
$msg .= $perl_minimal_version_supported;
$msg .= " current: ";
$msg .= $perl_current_version;
$msg .= "\n";
print $msg;
exit (1);
}
} #-- End of INIT
#------------------------------------------------------------------------------
# Poor man's version of a boolean.
#------------------------------------------------------------------------------
my $TRUE = 1;
my $FALSE = 0;
#------------------------------------------------------------------------------
# The total number of functions to be processed.
#------------------------------------------------------------------------------
my $g_total_function_count = 0;
#------------------------------------------------------------------------------
# Used to ensure correct alignment of columns.
#------------------------------------------------------------------------------
my $g_max_length_first_metric;
#------------------------------------------------------------------------------
# This variable contains the path used to execute $GP_DISPAY_TEXT.
#------------------------------------------------------------------------------
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_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log";
#------------------------------------------------------------------------------
# Global variables.
#------------------------------------------------------------------------------
my $g_addressing_mode = "64 bit";
#------------------------------------------------------------------------------
# The global regex section.
#
# First step towards consolidating all regexes.
#------------------------------------------------------------------------------
my $g_less_than_regex = '<';
my $g_html_less_than_regex = '&lt;';
my $g_endbr_inst_regex = 'endbr[32|64]';
my $g_rm_surrounding_spaces_regex = '^\s+|\s+$';
#------------------------------------------------------------------------------
# For consistency, use a global variable.
#------------------------------------------------------------------------------
my $g_html_new_line = "<br>";
#------------------------------------------------------------------------------
# These are the regex's used.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Disassembly analysis
#------------------------------------------------------------------------------
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*';
my $g_first_metric;
my $binutils_version;
my $driver_cmd;
my $tool_name;
my $version_info;
my %g_mapped_cmds = ();
#------------------------------------------------------------------------------
# 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;
#------------------------------------------------------------------------------
# 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
# structure because otherwise the code would get much more complicated.
#------------------------------------------------------------------------------
my %g_tagged_names = ();
#------------------------------------------------------------------------------
# TBD Remove the use of these structures. No longer used.
#------------------------------------------------------------------------------
my %g_function_tag_id = ();
my $g_context = 5; # Defines the range of scan
my $g_default_setting_lang = "en-US.UTF-8";
my %g_exp_dir_meta_data;
my $g_html_credits_line;
my $g_warn_keyword = "[Warning]";
my $g_error_keyword = "[Error]";
my %g_function_occurrences = ();
my %g_map_function_to_index = ();
my %g_multi_count_function = ();
my %g_function_view_all = ();
my @g_full_function_view_table = ();
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.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# This table has the settings of the variables the user may set.
#------------------------------------------------------------------------------
my %g_user_settings =
(
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},
);
#------------------------------------------------------------------------------
# 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,
"m" => $FALSE,
"l" => $FALSE,
"xl" => $FALSE,
);
my %local_system_config =
(
kernel_name => "undefined",
nodename => "undefined",
kernel_release => "undefined",
kernel_version => "undefined",
machine => "undefined",
processor => "undefined",
hardware_platform => "undefined",
operating_system => "undefined",
hostname_current => "undefined",
);
#------------------------------------------------------------------------------
# Note that we use single quotes here, because regular expressions wreak
# havoc otherwise.
#------------------------------------------------------------------------------
my %g_arch_specific_settings =
(
arch_supported => $FALSE,
arch => 'undefined',
regex => 'undefined',
subexp => 'undefined',
linksubexp => 'undefined',
);
my %g_locale_settings = (
LANG => "en_US.UTF-8",
decimal_separator => "\\.",
covert_to_dot => $FALSE
);
#------------------------------------------------------------------------------
# See this page for a nice overview with the colors:
# https://www.w3schools.com/colors/colors_groups.asp
#------------------------------------------------------------------------------
my %g_html_color_scheme = (
"control_flow" => "Brown",
"target_function_name" => "Red",
"non_target_function_name" => "BlueViolet",
"background_color_hot" => "PeachPuff",
"background_color_lukewarm" => "LemonChiffon",
"link_outside_range" => "Crimson",
"error_message" => "LightPink",
"background_color_page" => "White",
# "background_color_page" => "LightGray",
"background_selected_sort" => "LightSlateGray",
"index" => "Lavender",
);
#------------------------------------------------------------------------------
# These are the base names for the HTML files that are generated.
#------------------------------------------------------------------------------
my %g_html_base_file_name = (
"caller_callee" => "caller-callee",
"disassembly" => "dis",
"experiment_info" => "experiment-info",
"function_view" => "function-view-sorted",
"index" => "index",
"source" => "src",
"warnings" => "warnings",
);
#------------------------------------------------------------------------------
# Introducing main() is cosmetic, but helps with the scoping of variables.
#------------------------------------------------------------------------------
main ();
exit (0);
#------------------------------------------------------------------------------
# This is the driver part of the program.
#------------------------------------------------------------------------------
sub main
{
my $subr_name = get_my_name ();
@CopyOfARGV = @ARGV;
#------------------------------------------------------------------------------
# The name of the configuration file.
#------------------------------------------------------------------------------
my $rc_file_name = ".gp-display-html.rc";
#------------------------------------------------------------------------------
# OS commands executed and search paths.
#
# TBD: check if elfdump should be here too (most likely not though)
#------------------------------------------------------------------------------
my @selected_os_cmds = qw (rm cat hostname locale which printenv uname
readelf mkdir);
my @search_paths_os_cmds = qw (
/usr/bin
/bin
/usr/local/bin
/usr/local/sbin
/usr/sbin
/sbin
);
#------------------------------------------------------------------------------
# TBD: Eliminate these.
#------------------------------------------------------------------------------
my $ARCHIVES_MAP_NAME;
my $ARCHIVES_MAP_VADDR;
#------------------------------------------------------------------------------
# Local structures (hashes and arrays).
#------------------------------------------------------------------------------
my @exp_dir_list = ();
my @metrics_data;
my %function_address_info = ();
my $function_address_info_ref;
my @function_info = ();
my $function_info_ref;
my %function_address_and_index = ();
my $function_address_and_index_ref;
my %addressobjtextm = ();
my $addressobjtextm_ref;
my %addressobj_index = ();
my $addressobj_index_ref;
my %LINUX_vDSO = ();
my $LINUX_vDSO_ref;
my %function_view_structure = ();
my $function_view_structure_ref;
my %elf_rats = ();
my $elf_rats_ref;
#------------------------------------------------------------------------------
# Local variables.
#------------------------------------------------------------------------------
my $abs_path_outputdir;
my $archive_dir_not_empty;
my $base_va_executable;
my $executable_name;
my $found_exp_dir;
my $ignore_value;
my $msg;
my $number_of_metrics;
my $va_executable_in_hex;
my $failed_command_mappings;
my $script_pc_metrics;
my $dir_check_errors;
my $consistency_errors;
my $outputdir;
my $return_code;
my $decimal_separator;
my $convert_to_dot;
my $architecture_supported;
my $elf_arch;
my $elf_support;
my $home_dir;
my $elf_loadobjects_found;
my $rc_file_paths_ref;
my @rc_file_paths = ();
my $rc_file_errors = 0;
my @sort_fields = ();
my $summary_metrics;
my $call_metrics;
my $user_metrics;
my $system_metrics;
my $wall_metrics;
my $detail_metrics;
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 %metric_value = ();
my %metric_description = ();
my %metric_description_reversed = ();
my %metric_found = ();
my %ignored_metrics = ();
my $metric_value_ref;
my $metric_description_ref;
my $metric_found_ref;
my $ignored_metrics_ref;
my @table_execution_stats = ();
my $table_execution_stats_ref;
my $html_first_metric_file_ref;
my $html_first_metric_file;
my $arch;
my $subexp;
my $linksubexp;
my $setting_for_LANG;
my $time_percentage_multiplier;
my $process_all_functions;
my $selected_archive;
#------------------------------------------------------------------------------
# If no options are given, print the help info and exit.
#------------------------------------------------------------------------------
if ($#ARGV == -1)
{
$ignore_value = print_help_info ();
return (0);
}
#------------------------------------------------------------------------------
# This part is like a preamble. Before we continue we need to figure out some
# things that are needed later on.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Store the absolute path of the command executed.
#------------------------------------------------------------------------------
my $location_gp_command = $0;
#------------------------------------------------------------------------------
# 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 warnings and
# errors. The warnings, if any, will be printed once the command line has
# been parsed and verified. Execution continues.
#
# Any error(s) accumulated in this phase will be printed after the command
# line has been parsed and verified. Execution is then terminated.
#
# 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.
#------------------------------------------------------------------------------
my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options ();
$found_exp_dir = ${ $found_exp_dir_ref };
if ($found_exp_dir)
{
@exp_dir_list = @{ $exp_dir_list_ref };
}
else
{
$msg = "the list with experiments is either missing, or incorrect";
gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# The final settings for verbose, debug, warnings and quiet are known and the
# gp_message() subroutine is aware of these.
#------------------------------------------------------------------------------
$msg = "parsing of the user options completed";
gp_message ("verbose", $subr_name, $msg);
#------------------------------------------------------------------------------
# The user options have been taken in. Check for validity and consistency.
#------------------------------------------------------------------------------
$msg = "process user options";
gp_message ("verbose", $subr_name, $msg);
($ignored_metrics_ref, $outputdir,
$time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) =
process_user_options (\@exp_dir_list);
@exp_dir_list = @{ $exp_dir_list_ref };
%ignored_metrics = %{$ignored_metrics_ref};
#------------------------------------------------------------------------------
# The next subroutine is executed early to ensure the OS commands we need are
# available.
#
# 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).
#------------------------------------------------------------------------------
gp_message ("debug", $subr_name, "verify the OS commands");
$failed_command_mappings = check_and_define_cmds (\@selected_os_cmds,
\@search_paths_os_cmds);
if ($failed_command_mappings == 0)
{
$msg = "successfully verified the OS commands";
gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Time to check if any warnings and/or errors have been generated.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# 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.
#------------------------------------------------------------------------------
if ($g_debug)
{
$msg = "internal settings after option processing";
$ignore_value = print_table_user_settings ("diag", $msg);
}
#------------------------------------------------------------------------------
# Terminate execution in case fatal errors have occurred.
#------------------------------------------------------------------------------
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, $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);
#------------------------------------------------------------------------------
# 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 };
$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
#------------------------------------------------------------------------------
$pretty_dir_list = build_pretty_dir_list (\@exp_dir_list);
my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is";
$msg = "the experiment " . $plural . ":";
gp_message ("verbose", $subr_name, $msg);
gp_message ("verbose", $subr_name, $pretty_dir_list);
#------------------------------------------------------------------------------
# Set up the first entry with the meta data for the experiments. This field
# contains the absolute paths to the experiment directories.
#------------------------------------------------------------------------------
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;
}
#------------------------------------------------------------------------------
# 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.
#------------------------------------------------------------------------------
($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);
if ($consistency_errors == 0)
{
$msg = "the experiment directories are consistent";
gp_message ("verbose", $subr_name, $msg);
}
else
{
$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"};
$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.
#------------------------------------------------------------------------------
$g_path_to_tools = ${ check_availability_tool (\$location_gp_command)};
$GP_DISPLAY_TEXT = $g_path_to_tools . $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, print a warning only, since this may not be fatal but could
# potentially lead to issues later on.
#------------------------------------------------------------------------------
if (not is_file_executable ($GP_DISPLAY_TEXT))
{
$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) =
determine_decimal_separator ();
if ($return_code == 0)
{
$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
{
$msg = "the decimal separator cannot be determined -";
$msg .= " set to $decimal_separator";
gp_message ("warning", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Collect and store the system information.
#------------------------------------------------------------------------------
$msg = "collect system information and adapt settings";
gp_message ("verbose", $subr_name, $msg);
$return_code = get_system_config_info ();
#------------------------------------------------------------------------------
# The 3 variables below are used in the remainder.
#
# The output from "uname -p" is recommended to be used for the ISA.
#------------------------------------------------------------------------------
my $hostname_current = $local_system_config{hostname_current};
my $arch_uname_s = $local_system_config{kernel_name};
my $arch_uname = $local_system_config{processor};
gp_message ("debug", $subr_name, "set hostname_current = $hostname_current");
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
# includes several definitions of regular expressions.
#------------------------------------------------------------------------------
($architecture_supported, $elf_arch, $elf_support) =
set_system_specific_variables ($arch_uname, $arch_uname_s);
$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)
{
$msg = "g_arch_specific_settings{$feature} = ";
$msg .= $g_arch_specific_settings{$feature};
gp_message ("debug", $subr_name, $msg);
}
$arch = $g_arch_specific_settings{"arch"};
$subexp = $g_arch_specific_settings{"subexp"};
$linksubexp = $g_arch_specific_settings{"linksubexp"};
$g_locale_settings{"LANG"} = get_LANG_setting ();
$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.
#------------------------------------------------------------------------------
$ignore_value = reset_selected_settings ();
#------------------------------------------------------------------------------
# TBD: Revisit. Is this really necessary?
#------------------------------------------------------------------------------
($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;
$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 () };
$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.
#
# TBD: Push this into a subroutine(s).
#------------------------------------------------------------------------------
$outputdir = append_forward_slash ($outputdir);
gp_message ("debug", $subr_name, "prepared outputdir = $outputdir");
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# ******* TBD: e.system not available on Linux!!
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
## my $summary_metrics = 'e.totalcpu';
$detail_metrics = 'e.totalcpu';
$detail_metrics_system = 'e.totalcpu:e.system';
$call_metrics = 'a.totalcpu';
my $cmd_options;
my $metrics_cmd;
my $outfile1 = $outputdir ."metrics";
my $outfile2 = $outputdir . "metrictotals";
my $gp_error_file = $outputdir . $g_gp_error_logfile;
#------------------------------------------------------------------------------
# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is
# to get all the output in files $outfile1 and $outfile2. These are then
# parsed.
#------------------------------------------------------------------------------
$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);
if ($return_code != 0)
{
gp_message ("abort", $subr_name, "execution terminated");
}
#------------------------------------------------------------------------------
# TBD: Test this code
#------------------------------------------------------------------------------
$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>);
close (METRICS);
for my $i (keys @metrics_data)
{
$msg = "metrics_data[$i] = " . $metrics_data[$i];
gp_message ("debugXL", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Process the generated metrics data.
#------------------------------------------------------------------------------
if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
#------------------------------------------------------------------------------
# The metrics will be derived from the experiments.
#------------------------------------------------------------------------------
{
gp_message ("verbose", $subr_name, "Process the metrics data");
($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_value = %{ $metric_value_ref };
%metric_description = %{ $metric_description_ref };
%metric_found = %{ $metric_found_ref };
%metric_description_reversed = reverse %metric_description;
$msg = "after the call to process_metrics_data";
gp_message ("debugXL", $subr_name, $msg);
for my $metric (sort keys %metric_value)
{
$msg = "metric_value{$metric} = " . $metric_value{$metric};
gp_message ("debugXL", $subr_name, $msg);
}
for my $metric (sort keys %metric_description)
{
$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");
gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics");
}
else
{
#------------------------------------------------------------------------------
# A default set of metrics will be used.
#
# TBD: These should be OS dependent.
#------------------------------------------------------------------------------
$msg = "select the set of default metrics";
gp_message ("verbose", $subr_name, $msg);
($metric_description_ref, $metric_found_ref, $summary_metrics,
$detail_metrics, $detail_metrics_system, $call_metrics
) = set_default_metrics ($outfile1, \%ignored_metrics);
%metric_description = %{ $metric_description_ref };
%metric_found = %{ $metric_found_ref };
%metric_description_reversed = reverse %metric_description;
$msg = "after the call to set_default_metrics";
gp_message ("debug", $subr_name, $msg);
}
$number_of_metrics = split (":", $summary_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)
{
$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}))
{
$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.
#------------------------------------------------------------------------------
$msg = "generate the experiment information";
gp_message ("verbose", $subr_name, $msg);
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"} . " => " .
$experiment_data[$i]{"exp_name_full"};
gp_message ("debugM", $subr_name, $msg);
}
$experiment_data_ref = process_experiment_info ($experiment_data_ref);
@experiment_data = @{ $experiment_data_ref };
for my $i (sort keys @experiment_data)
{
for my $fields (sort keys %{ $experiment_data[$i] })
{
my $msg = "i = $i experiment_data[$i]{$fields} = " .
$experiment_data[$i]{$fields};
gp_message ("debugXL", $subr_name, $msg);
}
}
@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 = @{ $table_execution_stats_ref };
#------------------------------------------------------------------------------
# Get the function overview.
#------------------------------------------------------------------------------
$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);
@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);
($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 };
%addressobjtextm = %{ $addressobjtextm_ref };
%LINUX_vDSO = %{ $LINUX_vDSO_ref };
%function_view_structure = %{ $function_view_structure_ref };
$msg = "found " . $g_total_function_count . " functions to process";
gp_message ("verbose", $subr_name, $msg);
for my $keys (0 .. $#function_info)
{
for my $fields (keys %{$function_info[$keys]})
{
$msg = "$keys $fields $function_info[$keys]{$fields}";
gp_message ("debugXL", $subr_name, $msg);
}
}
for my $i (keys %addressobjtextm)
{
$msg = "addressobjtextm{$i} = " . $addressobjtextm{$i};
gp_message ("debugXL", $subr_name, $msg);
}
$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,
$sort_fields_ref);
$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,
\@sort_fields);
$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.
#------------------------------------------------------------------------------
$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);
#------------------------------------------------------------------------------
# Parse the source information 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.
#------------------------------------------------------------------------------
$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);
#------------------------------------------------------------------------------
# Parse the calltree information and generate the html files.
#------------------------------------------------------------------------------
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
{
$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);
}
#------------------------------------------------------------------------------
# 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);
#------------------------------------------------------------------------------
# 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);
$html_first_metric_file = ${ $html_first_metric_file_ref };
$msg = "html_first_metric_file = " . $html_first_metric_file;
gp_message ("debugXL", $subr_name, $msg);
$html_test = ${ generate_home_link ("left") };
$msg = "html_test = " . $html_test;
gp_message ("debugXL", $subr_name, $msg);
#------------------------------------------------------------------------------
# Unconditionnaly generate the page with the warnings.
#------------------------------------------------------------------------------
$ignore_value = html_create_warnings_page (\$outputdir);
#------------------------------------------------------------------------------
# Generate the index.html file.
#------------------------------------------------------------------------------
$msg = "generate the index.html file";
gp_message ("verbose", $subr_name, $msg);
$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);
#------------------------------------------------------------------------------
# We're done. In debug mode, print the meta data for the experiment
# directories.
#------------------------------------------------------------------------------
$ignore_value = print_meta_data_experiments ("debug");
#------------------------------------------------------------------------------
# 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 = ();
}
#------------------------------------------------------------------------------
# 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);
}
#------------------------------------------------------------------------------
# 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 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
# easier to construct pathnames.
#------------------------------------------------------------------------------
sub append_forward_slash
{
my $subr_name = get_my_name ();
my ($input_string) = @_;
my $length_of_string = length ($input_string);
my $return_string = $input_string;
if (rindex ($input_string, "/") != $length_of_string-1)
{
$return_string .= "/";
}
return ($return_string);
} #-- End of subroutine append_forward_slash
#------------------------------------------------------------------------------
# Return a string with a comma separated list of directory names.
#------------------------------------------------------------------------------
sub build_pretty_dir_list
{
my $subr_name = get_my_name ();
my ($dir_list_ref) = @_;
my @dir_list = @{ $dir_list_ref};
my $pretty_dir_list = join ("\n", @dir_list);
return ($pretty_dir_list);
} #-- End of subroutine build_pretty_dir_list
#------------------------------------------------------------------------------
# Calculate the target address in hex by adding the instruction to the
# instruction address.
#------------------------------------------------------------------------------
sub calculate_target_hex_address
{
my $subr_name = get_my_name ();
my ($instruction_address, $instruction_offset) = @_;
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 $result;
if ($g_addressing_mode eq "64 bit")
{
$mask = "0xffffffffffffffff";
$number_of_fields = 16;
}
else
{
$msg = "g_addressing_mode = $g_addressing_mode not supported";
gp_message ("abort", $subr_name, $msg);
}
$length_of_string = length ($instruction_offset);
$first_char = lcfirst (substr ($instruction_offset,0,1));
$d1 = bigint::hex ($instruction_offset);
$d2 = bigint::hex ($mask);
# if ($first_char eq "f")
if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields))
{
#------------------------------------------------------------------------------
# The offset is negative. Convert to decimal and perform the subtrraction.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# XOR the decimal representation and add 1 to the result.
#------------------------------------------------------------------------------
$result = ($d1 ^ $d2) + 1;
$dec_branch_target = bigint::hex ($instruction_address) - $result;
}
else
{
$result = $d1;
$dec_branch_target = bigint::hex ($instruction_address) + $result;
}
#------------------------------------------------------------------------------
# Convert to hexadecimal.
#------------------------------------------------------------------------------
$raw_hex_branch_target = sprintf ("%x", $dec_branch_target);
return ($raw_hex_branch_target);
} #-- End of subroutine calculate_target_hex_address
#------------------------------------------------------------------------------
# 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.
#
# The commands and their respective paths are stored in hash "g_mapped_cmds".
#------------------------------------------------------------------------------
sub check_and_define_cmds
{
my $subr_name = get_my_name ();
my ($cmds_ref, $search_path_ref) = @_;
#------------------------------------------------------------------------------
# Dereference the array addressess first and then store the contents.
#------------------------------------------------------------------------------
my @cmds = @{$cmds_ref};
my @search_path = @{$search_path_ref};
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 ("debugXL", $subr_name, "\@cmds = @cmds");
gp_message ("debugXL", $subr_name, "\@search_path = @search_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 $cmd (@cmds)
{
$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?
#------------------------------------------------------------------------------
{
#------------------------------------------------------------------------------
# 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)
{
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 ($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;
}
}
}
}
#------------------------------------------------------------------------------
# Scan the results stored in $g_mapped_cmds and flag errors.
#------------------------------------------------------------------------------
$no_of_failed_mappings = 0;
$failed_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")
{
$msg = "cannot find a path for command $cmd";
gp_message ("warning", $subr_name, $msg);
gp_message ("debug", $subr_name, $msg);
$no_of_failed_mappings++;
$failed_cmds .= $cmd;
$g_mapped_cmds{$cmd} = $cmd;
}
else
{
$msg = "path for the $cmd command is $mapped";
gp_message ("debug", $subr_name, $msg);
}
}
if ($no_of_failed_mappings != 0)
{
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);
} #-- End of subroutine check_and_define_cmds
#------------------------------------------------------------------------------
# Look for a branch instruction, or the special endbr32/endbr64 instruction
# that is also considered to be a branch target. Note that the latter is x86
# specific.
#------------------------------------------------------------------------------
sub check_and_proc_dis_branches
{
my $subr_name = get_my_name ();
my ($input_line_ref, $line_no_ref, $branch_target_ref,
$extended_branch_target_ref, $branch_target_no_ref_ref) = @_;
my $input_line = ${ $input_line_ref };
my $line_no = ${ $line_no_ref };
my %branch_target = %{ $branch_target_ref };
my %extended_branch_target = %{ $extended_branch_target_ref };
my %branch_target_no_ref = %{ $branch_target_no_ref_ref };
my $found_it = $TRUE;
my $hex_branch_target;
my $instruction_address;
my $instruction_offset;
my $msg;
my $raw_hex_branch_target;
if ( ($input_line =~ /$g_branch_regex/)
or ($input_line =~ /$g_endbr_regex/))
{
if (defined ($3))
{
$msg = "found a branch or endbr instruction: " .
"\$1 = $1 \$2 = $2 \$3 = $3";
}
else
{
$msg = "found a branch or endbr instruction: " .
"\$1 = $1 \$2 = $2";
}
gp_message ("debugXL", $subr_name, $msg);
if (defined ($1))
{
#------------------------------------------------------------------------------
# Found a qualifying instruction
#------------------------------------------------------------------------------
$instruction_address = $1;
if (defined ($3))
{
#------------------------------------------------------------------------------
# This must be the branch target and needs to be converted and processed.
#------------------------------------------------------------------------------
$instruction_offset = $3;
$raw_hex_branch_target = calculate_target_hex_address (
$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;
}
if (defined ($2) and (not defined ($3)))
{
#------------------------------------------------------------------------------
# Unlike a branch, the endbr32/endbr64 instructions do not have a second field.
#------------------------------------------------------------------------------
my $instruction_name = $2;
if ($instruction_name =~ /$g_endbr_inst_regex/)
{
my $msg = "found endbr: $instruction_name " .
$instruction_address;
gp_message ("debugXL", $subr_name, $msg);
$raw_hex_branch_target = $instruction_address;
$hex_branch_target = "0x" . $raw_hex_branch_target;
$branch_target_no_ref{$instruction_address} = 1;
}
}
}
else
{
#------------------------------------------------------------------------------
# TBD: Perhaps this should be an assertion or alike.
#------------------------------------------------------------------------------
$branch_target{"0x0000"} = $FALSE;
$msg = "cannot determine branch target";
gp_message ("debug", $subr_name, $msg);
}
}
else
{
$found_it = $FALSE;
}
return (\$found_it, \%branch_target, \%extended_branch_target,
\%branch_target_no_ref);
} #-- End of subroutine check_and_proc_dis_branches
#------------------------------------------------------------------------------
# Check an input line from the disassembly file to include a function call.
# If it does, process the line and return the branch target results.
#------------------------------------------------------------------------------
sub check_and_proc_dis_func_call
{
my $subr_name = get_my_name ();
my ($input_line_ref, $line_no_ref, $branch_target_ref,
$extended_branch_target_ref) = @_;
my $input_line = ${ $input_line_ref };
my $line_no = ${ $line_no_ref };
my %branch_target = %{ $branch_target_ref };
my %extended_branch_target = %{ $extended_branch_target_ref };
my $found_it = $TRUE;
my $hex_branch_target;
my $instruction_address;
my $instruction_offset;
my $msg;
my $raw_hex_branch_target;
if ( $input_line =~ /$g_function_call_v2_regex/ )
{
$msg = "found a function call - line[$line_no] = $input_line";
gp_message ("debugXL", $subr_name, $msg);
if (not defined ($2))
{
$msg = "line[$line_no] " .
"an instruction address is expected, but not found";
gp_message ("assertion", $subr_name, $msg);
}
else
{
$instruction_address = $2;
$msg = "instruction_address = $instruction_address";
gp_message ("debugXL", $subr_name, $msg);
if (not defined ($4))
{
$msg = "line[$line_no] " .
"an address offset is expected, but not found";
gp_message ("assertion", $subr_name, $msg);
}
else
{
$instruction_offset = $4;
if ($instruction_offset =~ /[0-9a-fA-F]+/)
{
$msg = "calculate branch target: " .
"instruction_address = $instruction_address";
gp_message ("debugXL", $subr_name, $msg);
$msg = "calculate branch target: " .
"instruction_offset = $instruction_offset";
gp_message ("debugXL", $subr_name, $msg);
#------------------------------------------------------------------------------
# The instruction offset needs to be converted and added to the instruction
# address.
#------------------------------------------------------------------------------
$raw_hex_branch_target = calculate_target_hex_address (
$instruction_address,
$instruction_offset);
$hex_branch_target = "0x" . $raw_hex_branch_target;
$msg = "calculated hex_branch_target = " .
$hex_branch_target;
gp_message ("debugXL", $subr_name, $msg);
$branch_target{$hex_branch_target} = 1;
$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}";
$msg .= " = $extended_branch_target{$instruction_address}";
gp_message ("debugXL", $subr_name, $msg);
}
else
{
$msg = "line[$line_no] unknown address format";
gp_message ("assertion", $subr_name, $msg);
}
}
}
}
else
{
$found_it = $FALSE;
}
return (\$found_it, \%branch_target, \%extended_branch_target);
} #-- End of subroutine check_and_proc_dis_func_call
#------------------------------------------------------------------------------
# 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 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 $subr_name = get_my_name ();
my ($location_gp_command_ref) = @_;
my $error_code;
my $error_occurred;
my $gp_path;
my $msg;
my $output_which_gp_display_text;
my $return_value;
my $target_cmd;
#------------------------------------------------------------------------------
# Get the path to gp-display-text.
#------------------------------------------------------------------------------
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)
#------------------------------------------------------------------------------
# All is well and gp-display-text has been located.
#------------------------------------------------------------------------------
{
$g_path_to_tools = $return_value;
$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);
}
else
#------------------------------------------------------------------------------
# Something went wrong, but perhaps we can still continue. Try to find
# $GP_DISPLAY_TEXT through the search path.
#------------------------------------------------------------------------------
{
$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 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);
if ($error_code == 0)
{
my ($gp_file_name, $gp_path, $suffix_not_used) =
fileparse ($output_which_gp_display_text);
$g_path_to_tools = $gp_path;
$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 ("error", $subr_name, $msg);
$g_total_error_count++;
gp_message ("abort", $subr_name, $g_abort_msg);
}
}
return (\$g_path_to_tools);
} #-- End of subroutine check_availability_tool
#------------------------------------------------------------------------------
# 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
# possible bug.
#
# Also, by isolating the tests for the input files, another nesting level could
# be eliminated, further simplifying this still too complex code.
#------------------------------------------------------------------------------
sub check_loadobjects_are_elf
{
my $subr_name = get_my_name ();
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 $elf_magic_number;
my $executable_name;
my $va_executable_in_hex;
my $arch_exp;
my $hostname_exp;
my $os_exp;
my $os_exp_full;
my $archives_file;
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_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 .= $selected_archive;
$path_to_log_file .= "/log.xml";
gp_message ("debug", $subr_name, "hostname_current = $hostname_current");
gp_message ("debug", $subr_name, "arch = $arch");
gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s");
#------------------------------------------------------------------------------
# TBD
#
# 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 . $msg . " " . $!);
$msg = "opened file $path_to_log_file for reading";
gp_message ("debug", $subr_name, $msg);
while (<LOG_XML>)
{
$line = $_;
chomp ($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">
#------------------------------------------------------------------------------
if ($line =~ /^\s*<system\s+/)
{
$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;
$msg = "extracted hostname_exp = " . $hostname_exp;
gp_message ("debugM", $subr_name, $msg);
}
if ($line =~ /.*\s+arch="([^"]+)/)
{
$arch_exp = $1;
$msg = "extracted arch_exp = " . $arch_exp;
gp_message ("debugM", $subr_name, $msg);
}
if ($line =~ /.*\s+os="([^"]+)/)
{
$os_exp_full = $1;
#------------------------------------------------------------------------------
# Capture the first word only.
#------------------------------------------------------------------------------
if ($os_exp_full =~ /([^\s]+)/)
{
$os_exp = $1;
}
$msg = "extracted os_exp = " . $os_exp;
gp_message ("debugM", $subr_name, $msg);
}
last;
}
} #-- End of while loop
close (LOG_XML);
#------------------------------------------------------------------------------
# If the current system is identical to the system used in the experiment,
# we can return early. Otherwise we need to dig deeper.
#
# TBD: How about the other experiment directories?! This needs to be fixed.
#------------------------------------------------------------------------------
gp_message ("debug", $subr_name, "completed while loop");
gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp");
gp_message ("debug", $subr_name, "arch_exp = $arch_exp");
gp_message ("debug", $subr_name, "os_exp = $os_exp");
#TBD: THIS DOES NOT CHECK IF ELF IS FOUND!
if (($hostname_current eq $hostname_exp) and
($arch eq $arch_exp) and
($arch_uname_s eq $os_exp))
{
$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"})
{
$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"}})
{
$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
# and the virtual address.
#------------------------------------------------------------------------------
if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"})
{
$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);
}
$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";
$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>)
{
$line = $_;
chomp ($line);
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 ("debugM", $subr_name, "target line = $line");
$vaddr = $1;
$foffset = $2;
$modes = $3;
$name_path = $4;
$name = get_basename ($name_path);
$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;
$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;
last;
}
}
}
close (MAP_XML);
if (not $extracted_information)
{
$msg = "cannot find the necessary information in";
$msg .= " the $path_to_map_file file";
gp_message ("assertion", $subr_name, $msg);
}
## $executable_name = $ARCHIVES_MAP_NAME;
## $va_executable_in_hex = $ARCHIVES_MAP_VADDR;
return ($executable_name, $va_executable_in_hex);
} #-- End of subroutine check_loadobjects_are_elf
#------------------------------------------------------------------------------
# Compare the current metric values against the maximum values. Mark the line
# if a value is within the percentage defined by $hp_value.
#------------------------------------------------------------------------------
sub check_metric_values
{
my $subr_name = get_my_name ();
my ($metric_values, $max_metric_values_ref) = @_;
my @max_metric_values = @{ $max_metric_values_ref };
my @current_metrics = ();
my $colour_coded_line;
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);
$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];
$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?
$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)
{
$msg = "metric $metric is within the relative_distance";
gp_message ("debugXL", $subr_name, $msg);
$colour_coded_line = $TRUE;
last;
}
}
}
} #-- End of loop over metrics
return (\$colour_coded_line);
} #-- End of subroutine check_metric_values
#------------------------------------------------------------------------------
# Check if the system is supported.
#------------------------------------------------------------------------------
sub check_support_for_processor
{
my $subr_name = get_my_name ();
my ($machine_ref) = @_;
my $machine = ${ $machine_ref };
my $is_supported;
if ($machine eq "x86_64")
{
$is_supported = $TRUE;
}
else
{
$is_supported = $FALSE;
}
return (\$is_supported);
} #-- End of subroutine check_support_for_processor
#------------------------------------------------------------------------------
# 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.
#
# 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 following patterns are supposed to be detected:
#
# <expdir_1> some other word(s) <expdir_2>
# <expdir> some other word(s)
#------------------------------------------------------------------------------
sub check_the_experiment_list
{
my $subr_name = get_my_name ();
#------------------------------------------------------------------------------
# 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 $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;
for my $i (keys @ARGV)
{
$current_value = $ARGV[$i];
if ($current_value =~ /$exp_dir_regex/)
#------------------------------------------------------------------------------
# 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;
$current_value =~ s/$forward_slash_regex//;
push (@exp_dir_list, $current_value);
if (not $found_experiment)
#------------------------------------------------------------------------------
# Start checking for the next field(s).
#------------------------------------------------------------------------------
{
$found_experiment = $TRUE;
}
#------------------------------------------------------------------------------
# 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++;
}
}
else
{
$no_of_invalid_dirs++;
$msg = "directory " . get_basename($exp_dir) . " does not exist";
gp_message ("error", $subr_name, $msg);
$g_total_error_count++;
}
}
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);
## $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
#------------------------------------------------------------------------------
# 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 $missing_dirs = 0;
my $invalid_dirs = 0;
my $archive_dir_not_empty;
my $archives_dir;
my $archives_file;
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;
my $archive_dir_selected;
my $no_of_files_in_selected_archive;
#------------------------------------------------------------------------------
# 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;
}
#------------------------------------------------------------------------------
# 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"};
$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;
$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 ($_);
$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;
$msg = "last_dot = $last_dot";
gp_message ("debugXL", $subr_name, $msg);
while ($underscore_before_dot)
{
$first_underscore = index ($filename, "_", $first_underscore+1);
if ($last_dot < $first_underscore)
{
$underscore_before_dot = $FALSE;
}
}
my $original_name = substr ($filename, 0, $first_underscore);
$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;
$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"};
$msg = "archive directory " . $exp_dir . "/archives is";
$msg .= " " . ($empty ? "empty" : "not empty");
gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Verify that all relevant files in the archive directories are in ELF format.
#------------------------------------------------------------------------------
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
$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"};
$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"}})
{
$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 ($subr_name . $msg . " " . $!);
$first_line = <ARCF>;
close (ARCF);
#------------------------------------------------------------------------------
# The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF).
#
# See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format
#------------------------------------------------------------------------------
# if ($first_line =~ /^\177ELF.*/)
$elf_magic_number = unpack ('H8', $first_line);
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}{"elf_format"} = $TRUE;
last;
}
}
}
}
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
$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"})
{
$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 message
# is issued.
#
# TBD: Bail out?
#------------------------------------------------------------------------------
$count_exp_dir_not_elf = 0;
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"})
{
$count_exp_dir_not_elf++;
}
}
if ($count_exp_dir_not_elf != 0)
{
$msg = "there are $count_exp_dir_not_elf experiments with non-ELF";
$msg .= " load objects";
gp_message ("debug", $subr_name, $msg);
}
#------------------------------------------------------------------------------
# Select the experiment directory that is used for the files in the archive.
# By default, a directory with archived files is used, but in case this does
# not exist, a directory without archived files is selected. Obviously this
# needs to be dealt with later on.
#------------------------------------------------------------------------------
#------------------------------------------------------------------------------
# Try the experiments with archived files first.
#------------------------------------------------------------------------------
$archive_dir_not_empty = $FALSE;
$archive_dir_selected = $FALSE;
## for my $exp_dir (sort @exp_dir_list)
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
$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;
last;
}
}
if (not $archive_dir_selected)
#------------------------------------------------------------------------------
# None are found and pick the first one without archived files.
#------------------------------------------------------------------------------
{
for my $exp_dir (sort keys %g_exp_dir_meta_data)
{
if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
{
$selected_archive = $exp_dir;
$archive_dir_not_empty = $FALSE;
$archive_dir_selected = $TRUE;
$selected_archive_has_elf_format = $FALSE;
last;
}
}
}
$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"};
$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"};
$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"}})
{
$msg = $exp_dir . " " . $object . " ";
$msg .=
$g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object};
gp_message ("debug", $subr_name, $msg);
}
}
}
return ($archive_dir_not_empty, $selected_archive, \%elf_rats);
} #-- End of subroutine check_validity_exp_dirs
#------------------------------------------------------------------------------
# Color the string and optionally mark it boldface.
#
# For supported colors, see:
# https://www.w3schools.com/colors/colors_names.asp
#------------------------------------------------------------------------------
sub color_string
{
my $subr_name = get_my_name ();
my ($input_string, $boldface, $color) = @_;
my $colored_string;
$colored_string = "<font color='" . $color . "'>";
if ($boldface)
{
$colored_string .= "<b>";
}
$colored_string .= $input_string;
if ($boldface)
{
$colored_string .= "</b>";
}
$colored_string .= "</font>";
return ($colored_string);
} #-- End of subroutine color_string
#------------------------------------------------------------------------------
# Generate the array with the info on the experiment(s).
#------------------------------------------------------------------------------
sub create_exp_info
{
my $subr_name = get_my_name ();
my ($experiment_dir_list_ref, $experiment_data_ref) = @_;
my @experiment_dir_list = @{ $experiment_dir_list_ref };
my @experiment_data = @{ $experiment_data_ref };
my @experiment_stats_html = ();
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";
$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_stats_line .= $experiment_data[$i]{"start_date"} . ")\n";
}
$experiment_stats_line .= "</pre>\n";
push (@experiment_stats_html, $experiment_stats_line);
$msg = "experiment_stats_line = " . $experiment_stats_line;
gp_message ("debugXL", $subr_name, $msg);
return (\@experiment_stats_html);
} #-- End of subroutine create_exp_info
#------------------------------------------------------------------------------
# Trivial function to generate a tag. This has been made a function to ensure
# consistency creating tags and also make it easier to change them.
#------------------------------------------------------------------------------
sub create_function_tag
{
my $subr_name = get_my_name ();
my ($tag_id) = @_;
my $function_tag = "function_tag_" . $tag_id;
return ($function_tag);
} #-- End of subroutine create_function_tag
#------------------------------------------------------------------------------
# Generate and return a string with the credits. Note that this also ends
# the HTML formatting controls.
#------------------------------------------------------------------------------
sub create_html_credits
{
my $subr_name = get_my_name ();
my $msg;
my $the_date;
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 ();
$year += 1900;
$the_date = $months[$mon] . " " . $mday . ", " . $year;
$msg = "<i>\n";
$msg .= "Output generated by the $driver_cmd command ";
$msg .= "on $the_date ";
$msg .= "(GNU binutils version " . $binutils_version . ")";
$msg .= "\n";
$msg .= "</i>";
gp_message ("debug", $subr_name, "the date = $the_date");
return (\$msg);
} #-- End of subroutine create_html_credits
#------------------------------------------------------------------------------
# Generate a string that contains all the necessary HTML header information,
# plus a title.
#
# See also https://www.w3schools.com for the details on the features used.
#------------------------------------------------------------------------------
sub create_html_header
{
my $subr_name = get_my_name ();
my ($title_ref) = @_;
my $title = ${ $title_ref };
my $LANG = $g_locale_settings{"LANG"};
my $background_color = $g_html_color_scheme{"background_color_page"};
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\"";
$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 .= "<style>\n";
$html_header .= "div.left {\n";
$html_header .= "text-align: left;\n";
$html_header .= "}\n";
$html_header .= "div.right {\n";
$html_header .= "text-align: right;\n";
$html_header .= "}\n";
$html_header .= "div.center {\n";
$html_header .= "text-align: center;\n";
$html_header .= "}\n";
$html_header .= "div.justify {\n";
$html_header .= "text-align: justify;\n";
$html_header .= "}\n";
$html_header .= "</style>";
return (\$html_header);
} #-- End of subroutine create_html_header
#------------------------------------------------------------------------------
# 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 };
my @html_exp_table_data = ();
my $html_header_line;
my $html_table_line;
my $html_end_table;
$html_header_line = ${ create_table_header_exp (\@experiment_data) };
push (@html_exp_table_data, $html_header_line);
for my $i (sort keys @table_definition)
{
$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";
gp_message ("debugXL", $subr_name, $msg);
}
$html_end_table = "</table>\n";
push (@html_exp_table_data, $html_end_table);
return (\@html_exp_table_data);
} #-- 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 ($entry_name_ref, $key_ref, $experiment_data_ref) = @_;
my $entry_name = ${ $entry_name_ref };
my $key = ${ $key_ref };
my @experiment_data = @{ $experiment_data_ref };
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>&nbsp; ";
$html_line = "<tr><div class=\"right\"><td><b>&nbsp; ";
$html_line .= $entry_name;
$html_line .= " &nbsp;</b></td>";
for my $i (sort keys @experiment_data)
{
if (exists ($experiment_data[$i]{$key}))
{
$html_line .= "<td>&nbsp; " . $experiment_data[$i]{$key};
$html_line .= " &nbsp;</td>";
}
else
{
$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";
gp_message ("debugXL", $subr_name, "return html_line = $html_line");
return (\$html_line);
} #-- 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_ref) = @_;
my @experiment_data = @{ $experiment_data_ref };
my $html_header_line;
my $msg;
$html_header_line = "<style>\n";
$html_header_line .= "table, th, td {\n";
$html_header_line .= "border: 1px solid black;\n";
$html_header_line .= "border-collapse: collapse;\n";
$html_header_line .= "}\n";
$html_header_line .= "</style>\n";
$html_header_line .= "</pre>\n";
$html_header_line .= "<table>\n";
$html_header_line .= "<tr><div class=\"center\"><th></th>";
for my $i (sort keys @experiment_data)
{
$html_header_line .= "<th>&nbsp; Experiment ID ";
$html_header_line .= $experiment_data[$i]{"exp_id"} . "&nbsp;</th>";
}
$html_header_line .= "</div></tr>\n";
$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
# 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
# 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")
{ $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)
{
$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"};
my $rm_output = qx ($target_cmd -rf $outputdir);
my $error_code = ${^CHILD_ERROR_NATIVE};
if ($error_code != 0)
{
gp_message ("error", $subr_name, $rm_output);
$msg = "fatal error when trying to remove " . $outputdir;
gp_message ("abort", $subr_name, $msg);
}
else
{
$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
# $outputdir is known. Time to create it.
#------------------------------------------------------------------------------
if (mkdir ($outputdir, 0777))
{
$msg = "created output directory " . $outputdir;
gp_message ("debug", $subr_name, $msg);
}
else
{
$msg = "a fatal problem occurred when creating directory " . $outputdir;
gp_message ("abort", $subr_name, $msg);
}
return ($outputdir);
} #-- End of subroutine define_the_output_directory
#------------------------------------------------------------------------------
# Return the virtual address for the load object.
#
# Note that at this point, $elf_arch is known to be supported.
#
# TBD: Duplications?
#------------------------------------------------------------------------------
sub determine_base_va_address
{
my $subr_name = get_my_name ();
my ($executable_name, $base_va_executable, $loadobj, $routine) = @_;
my $msg;
my $name_loadobject;
my $base_va_address;
$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 <