public inbox for binutils-cvs@sourceware.org
help / color / mirror / Atom feed
From: Vladimir Mezentsev <vmezents@sourceware.org>
To: bfd-cvs@sourceware.org, gdb-cvs@sourceware.org
Subject: [binutils-gdb] gprofng: implement a functional gp-display-html
Date: Wed, 6 Jul 2022 21:59:45 +0000 (GMT) [thread overview]
Message-ID: <20220706215945.B17DC3858D28@sourceware.org> (raw)
https://sourceware.org/git/gitweb.cgi?p=binutils-gdb.git;h=41bbac64c36ffc5a418524be55fde20fad888e11
commit 41bbac64c36ffc5a418524be55fde20fad888e11
Author: Ruud van der Pas <ruud.vanderpas@oracle.com>
Date: Tue Jun 28 10:37:19 2022 -0700
gprofng: implement a functional gp-display-html
This patch enables the first support for the "gprofng display html" command.
This command works for C/C++ applications on x86_64. Using one or more gprofng
experiment directories as input, a new directory with html files is created.
Through the index.html file in this directory, the performance results may be
viewed in a browser.
gprofng/Changelog:
2022-06-28 Ruud van der Pas <ruud.vanderpas@oracle.com>
* gp-display-html/gp-display-html.in: implement first support for x86_64 and C/C++
Diff:
---
gprofng/gp-display-html/gp-display-html.in | 14631 ++++++++++++++++++++++++++-
1 file changed, 14468 insertions(+), 163 deletions(-)
diff --git a/gprofng/gp-display-html/gp-display-html.in b/gprofng/gp-display-html/gp-display-html.in
index f8fbc244c52..54a87d7a3c7 100644
--- a/gprofng/gp-display-html/gp-display-html.in
+++ b/gprofng/gp-display-html/gp-display-html.in
@@ -1,5 +1,4 @@
-#!/usr/bin/perl
-
+#!/usr/bin/env perl
# Copyright (C) 2021 Free Software Foundation, Inc.
# Contributed by Oracle.
#
@@ -20,14 +19,34 @@
# Foundation, 51 Franklin Street - Fifth Floor, Boston,
# MA 02110-1301, USA.
+use strict;
+use warnings;
+use feature qw (state);
+use File::stat;
+
#------------------------------------------------------------------------------
-# gp-display-html, last updated July 2021
-#
-# NOTE: This is a skeleton version. The real code will follow as an update.
+# 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;
-use strict;
-use warnings;
+ 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.
@@ -35,222 +54,14508 @@ use warnings;
my $TRUE = 1;
my $FALSE = 0;
+my $g_max_length_first_metric;
+
+#-------------------------------------------------------------------------------
+# 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 = '<';
+ my $g_endbr_inst_regex = 'endbr[32|64]';
+
+#------------------------------------------------------------------------------
+# 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*';
+
+#------------------------------------------------------------------------------
+# Convenience. These map the on/off value to $TRUE/$FALSE to make the code
+# easier to read. For example: "if ($g_verbose)" as opposed to the following:
+# "if ($verbose_setting eq "on").
+#------------------------------------------------------------------------------
+my $g_verbose;
+my $g_warnings;
+my $g_quiet;
+
+my $g_first_metric;
+
+my $binutils_version;
+my $driver_cmd;
+my $tool_name;
+my $version_info;
+
+my %g_mapped_cmds = ();
+
+#------------------------------------------------------------------------------
+# TBD All warning messages are collected and are accessible through the main
+# page.
+#------------------------------------------------------------------------------
+my @g_warning_messages = ();
+
+#------------------------------------------------------------------------------
+# 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_user_input_errors = ();
+
+my $g_html_credits_line;
+
+my $g_warn_keyword = "Input warning: ";
+my $g_error_keyword = "Input 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.
#-------------------------------------------------------------------------------
-my $driver_cmd = "gprofng display html";
-my $tool_name = "gp-display-html";
-my $binutils_version = "BINUTILS_VERSION";
-my $version_info = $tool_name . " GNU binutils version " . $binutils_version;
+$driver_cmd = "gprofng display html";
+$tool_name = "gp-display-html";
+#$binutils_version = "2.38.50";
+$binutils_version = "BINUTILS_VERSION";
+$version_info = $tool_name . " GNU binutils version " . $binutils_version;
+
+#-------------------------------------------------------------------------------
+
+#-------------------------------------------------------------------------------
+# Define several key data structures.
+#-------------------------------------------------------------------------------
+my %g_user_settings =
+ (
+ output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
+ overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
+ calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
+ func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE},
+ highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE},
+ threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE},
+ default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
+ ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE},
+ verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
+ warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE},
+ debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE},
+ quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
+ );
+
+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
+);
#------------------------------------------------------------------------------
-# This is cosmetic, but helps with the scoping of variables.
+# See this page for a nice overview with the colors:
+# https://www.w3schools.com/colors/colors_groups.asp
#------------------------------------------------------------------------------
- main ();
+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",
+);
- exit (0);
+#------------------------------------------------------------------------------
+# 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",
+);
#------------------------------------------------------------------------------
-# THE SUBROUTINES
+# This is cosmetic, but helps with the scoping of variables.
#------------------------------------------------------------------------------
+ main ();
+
+ exit (0);
#------------------------------------------------------------------------------
# This is the driver part of the program.
#------------------------------------------------------------------------------
-sub
-main
+sub main
{
- my $subr_name = "main";
- my $ignore_value;
+ my $subr_name = get_my_name ();
#------------------------------------------------------------------------------
-# If no options are given, print the help info and exit.
+# The name of the configuration file.
#------------------------------------------------------------------------------
- $ignore_value = early_scan_specific_options();
+ my $rc_file_name = ".gp-display-html.rc";
- $ignore_value = be_patient ();
+#------------------------------------------------------------------------------
+# OS commands executed and search paths.
+#------------------------------------------------------------------------------
+ my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls
+ uname readelf mkdir);
+ my @search_paths_os_cmds = qw (/usr/bin /bin);
- return (0);
+#------------------------------------------------------------------------------
+# TBD: Eliminate these.
+#------------------------------------------------------------------------------
+ my $ARCHIVES_MAP_NAME;
+ my $ARCHIVES_MAP_VADDR;
-} #-- End of subroutine main
+#------------------------------------------------------------------------------
+# Local structures (hashes and arrays).
+#------------------------------------------------------------------------------
+ my @exp_dir_list; # List with experiment directories
+ my @metrics_data;
-sub
-be_patient
-{
- print "Functionality not implemented yet - please stay tuned for updates\n";
+ 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;
-} #-- End of subroutine be_patient
+ 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;
#------------------------------------------------------------------------------
-# Prints the version number and license information.
+# Local variables.
#------------------------------------------------------------------------------
-sub
-print_version_info
-{
- print "$version_info\n";
- print "Copyright (C) 2021 Free Software Foundation, Inc.\n";
- print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n";
- print "This is free software: you are free to change and redistribute it.\n";
- print "There is NO WARRANTY, to the extent permitted by law.\n";
+ my $abs_path_outputdir;
+ my $archive_dir_not_empty;
+ my $base_va_executable;
+ my $executable_name;
+ my $exp_dir_list_ref;
+ my $found_exp_dir;
+ my $ignore_value;
+ my $message;
+ my $number_of_metrics;
+ my $va_executable_in_hex;
- return (0);
+ my $failed_command_mappings;
+ my $option_errors;
+ my $total_user_errors;
-} #-- End of subroutine print_version_info
+ my $script_pc_metrics;
+ my $dir_check_errors;
+ my $consistency_errors;
+ my $outputdir;
+ my $return_code;
-#-------------------------------------------------------------------------------
-# Print the help overview
-#-------------------------------------------------------------------------------
-sub
-print_help_info
-{
- print
- "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n".
- "\n".
- "Process one or more experiments to generate a directory containing an index.html\n".
- "file that can be used to browse the experiment data\n".
- "\n".
- "Options:\n".
- "\n".
- " --help print usage information and exit.\n".
- " --version print the version number and exit.\n".
- " --verbose {on|off} enable (on) or disable (off) verbose mode; the default is \"off\".\n".
- "\n".
- "\n".
- " -o, --output <dir-name> use <dir-name> to store the results in; the default\n".
- " name is ./display.<n>.html with <n> the first number\n".
- " not in use; an existing directory is not overwritten.\n".
- "\n".
- " -O, --overwrite <dir-name> use <dir-name> to store the results in and overwrite\n".
- " any existing directory with the same name; make sure\n".
- " that umask is set to the correct access permissions.\n".
- "\n".
- " -fl, --func_limit <limit> impose a limit on the number of functions processed;\n".
- " this is an integer number; set to 0 to process all\n".
- " functions; the default value is 100.\n".
- "\n".
- " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n".
- " from the bottom of the first page; default is off.\n".
- "\n".
- " -tp, --threshold_percentage <percentage> provide a percentage of metric accountability; the\n".
- " inclusion of functions for each metric will take\n".
- " place in sort order until the percentage has been\n".
- " reached.\n".
- "\n".
- " -dm, --default_metrics {on|off} enable or disable automatic selection of metrics\n".
- " and use a default set of metrics; the default is off.\n".
- "\n".
- " -im, --ignore_metrics <metric-list> ignore the metrics from <metric-list>.\n".
- "\n".
- " -db, --debug {on|off} enable/disable debug mode; print detailed information to assist with troubleshooting\n".
- " or further development of this tool; default is off.\n".
- "\n".
- " -q, --quiet {on|off} disable/enable the display of warnings; default is off.\n".
- "\n".
- "Environment:\n".
- "\n".
- "The options can be set in a configuration file called .gp-display-html.rc. This\n".
- "file needs to be either in the current directory, or in the home directory of the user.\n".
- "The long name of the option without the leading dashes is supported. For example calltree\n".
- "to enable or disable the call tree. Note that some options take a value. In case the same option\n".
- "occurs multiple times in this file, only the last setting encountered is preserved.\n".
- "\n".
- "Documentation:\n".
- "\n".
- "A getting started guide for gprofng is maintained as a Texinfo manual. If the info and\n".
- "gprofng programs are properly installed at your site, the command \"info gprofng\"\n".
- "should give you access to this document.\n".
- "\n".
- "See also:\n".
- "\n".
- "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), gp-display-text(1)\n";
+ my $decimal_separator;
+ my $convert_to_dot;
+ my $architecture_supported;
+ my $elf_arch;
+ my $elf_support;
+ my $home_dir;
+ my $elf_loadobjects_found;
- return (0);
+ my $rc_file_paths_ref;
+ my @rc_file_paths = ();
+ my $rc_file_errors = 0;
-} #-- End of subroutine print_help_info
+ 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 $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;
#------------------------------------------------------------------------------
-# Scan the command line for specific options.
+# If no options are given, print the help info and exit.
#------------------------------------------------------------------------------
-sub
-early_scan_specific_options
-{
- my $subr_name = "early_scan_specific_options";
+ if ($#ARGV == -1)
+ {
+ $ignore_value = print_help_info ();
+ return (0);
+ }
- my $ignore_value;
- my $found_option;
- my $option_has_value;
- my $option_value;
+#------------------------------------------------------------------------------
+# This part is like a preamble. Before we continue we need to figure out some
+# things that are needed later on.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# The very first thing to do is to quickly determine if the user has enabled
+# one of the following options and take action accordingly:
+# --version, --verbose, --debug, --quiet
+#
+# This avoids that there is a gap between the start of the execution and the
+# moment the options are parsed, checked, and interpreted.
+#
+# When parsing the full command line, these options will be more extensively
+# checked and also updated in %g_user_settings
+
+# Note that a confirmation message, if any, is printed here and not when the
+# options are parsed and processed.
+#------------------------------------------------------------------------------
+
+ $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
+ $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
+ $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
- my $verbose_setting = $FALSE;
- my $debug_setting = $FALSE;
- my $quiet_setting = $FALSE;
+ $ignore_value = early_scan_specific_options ();
- $option_has_value = $FALSE;
- ($found_option, $option_value) = find_target_option (\@ARGV, $option_has_value, "--version");
- if ($found_option)
+#------------------------------------------------------------------------------
+# 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).
+#------------------------------------------------------------------------------
+ $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds);
+
+ if ($failed_command_mappings == 0)
{
- $ignore_value = print_version_info ();
- exit(0);
+ gp_message ("debug", $subr_name, "verified the OS commands");
}
- $option_has_value = $FALSE;
- ($found_option, $option_value) = find_target_option (\@ARGV, $option_has_value, "--help");
- if ($found_option)
+ else
{
- $ignore_value = print_help_info ();
- exit(0);
+ my $msg = "failure in the verification of the OS commands";
+ gp_message ("assertion", $subr_name, $msg);
}
- return (0);
+#------------------------------------------------------------------------------
+# 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);
-} #-- End of subroutine early_scan_specific_options
+ @rc_file_paths = @{ $rc_file_paths_ref };
+ gp_message ("debug", $subr_name, "the home directory is $home_dir");
+ gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths");
+
+ $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths);
#------------------------------------------------------------------------------
-# Scan the command line to see if the specified option is present.
+# Get the ball rolling. Parse and interpret the configuration file (if any)
+# and the command line options.
#
-# Two types of options are supported: options without value (e.g. --help) or
-# those that are set to "on" or "off".
+# If either $rc_file_errors or $total_user_errors, or both, are non-zero it
+# means a fatal error has occured. In this case, all error messages are
+# printed and execution is terminated.
+#
+# Note that the verbose, debug, and quiet options can be set in this file.
+# It is a deliberate choice to ignore these for now. The assumption is that
+# the user will not be happy if we ignore the command line settings for a
+# while.
#------------------------------------------------------------------------------
-sub
-find_target_option
-{
- my ($command_line_ref, $has_value, $target_option) = @_;
- my @command_line = @{ $command_line_ref };
+ gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now");
+
+# Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file");
+# Temporarily disabled
+# Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref);
+# Temporarily disabled
+# Temporarily disabled if ($rc_file_errors != 0)
+# Temporarily disabled {
+# Temporarily disabled $message = "fatal errors in file $rc_file_name encountered";
+# Temporarily disabled gp_message ("debugXL", $subr_name, $message);
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file");
+
+#------------------------------------------------------------------------------
+# Get the ball rolling. Parse and interpret the options. Some first checks
+# are performed.
+#
+# Instead of bailing out on the first user error, we capture all errors, print
+# messages and then bail out. This is more user friendly.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Parse the user options");
+
+ $total_user_errors = 0;
- my ($command_line_string) = join(" ", @command_line);
+ ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options (
+ \$#ARGV,
+ \@ARGV);
+ $total_user_errors += $option_errors;
- my $option_value = "not set";
- my $found_option = $FALSE;
+#------------------------------------------------------------------------------
+# Dynamically load the modules needed. If a module is not available, print
+# an error message and bail out.
+#
+# This call replaces the following:
+#
+# use feature qw (state);
+# use List::Util qw (min max);
+# use Cwd;
+# use File::Basename;
+# use File::stat;
+# use POSIX;
+# use bignum;
+#
+# Note that this check cannot be done earlier, because in case of a missing
+# module, the man page would not be generated if the code ends prematurely
+# in case the --help and --version options are used..
+#------------------------------------------------------------------------------
+ my ($module_errors_ref, $missing_modules_ref) = handle_module_availability ();
+
+ my $module_errors = ${ $module_errors_ref };
- if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/)
+ if ($module_errors > 0)
{
- if ($has_value)
+ my $msg;
+
+ my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is";
+ my @missing_modules = @{ $missing_modules_ref };
+
+ for my $i (0 .. $#missing_modules)
{
+ $msg = "module $missing_modules[$i] is missing";
+ gp_message ("error", $subr_name, $msg);
+ }
+
+ $msg = $module_errors . " " . $plural_or_single .
+ "missing - execution is terminated";
+ gp_message ("abort", $subr_name, $msg);
+ }
+
#------------------------------------------------------------------------------
-# We are looking for this kind if substring: "--verbose on"
+# The user options have been taken in. Check for validity and consistency.
#------------------------------------------------------------------------------
- if (defined($1) and defined($2))
- {
- if ( ($2 eq "on") or ($2 eq "off") )
- {
- $found_option = $TRUE;
- $option_value = $2;
- }
- }
+ gp_message ("verbose", $subr_name, "Process user options");
+
+ ($option_errors, $ignored_metrics_ref, $outputdir,
+ $time_percentage_multiplier, $process_all_functions,
+ $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref);
+
+ @exp_dir_list = @{ $exp_dir_list_ref };
+ %ignored_metrics = %{$ignored_metrics_ref};
+
+ $total_user_errors += $option_errors;
+
+#------------------------------------------------------------------------------
+# If no option is given for the output directory, pick a default. Otherwise,
+# if the output directory exists, wipe it clean in case the -O option is used.
+# If not, flag an error because the -o option does not overwrite an existing
+# directory.
+#------------------------------------------------------------------------------
+ if ($total_user_errors == 0)
+ {
+ ($option_errors, $outputdir) = set_up_output_directory ();
+ $abs_path_outputdir = cwd () . "/" . $outputdir;
+ $total_user_errors += $option_errors;
+ }
+
+ if ($total_user_errors == 0)
+ {
+ gp_message ("debug", $subr_name, "the output directory is $outputdir");
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# All command line errors and warnings are printed here.
+#------------------------------------------------------------------------------
+ my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has";
+ $message = $g_error_keyword;
+ $message .= $total_user_errors;
+ if ($rc_file_errors > 0)
+ {
+ $message .= " additional";
}
- else
+ $message .= " fatal input $plural_or_single been detected:";
+ gp_message ("error", $subr_name, $message);
+ for my $key (keys @g_user_input_errors)
{
+ gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]");
+ }
+ }
+
#------------------------------------------------------------------------------
-# We are looking for this kind if substring: "--help"
+# Bail out in case fatal errors have occurred.
#------------------------------------------------------------------------------
- if (defined($1))
- {
- $found_option = $TRUE;
- }
- }
+ if ( ($rc_file_errors + $total_user_errors) > 0)
+ {
+ my $msg = "the current values for the user controllable settings";
+ print_user_settings ("debug", $msg);
+
+ gp_message ("abort", $subr_name, "execution terminated");
}
+ else
+ {
+ my $msg = "after parsing the user options, the final values are";
+ print_user_settings ("debug", $msg);
- return($found_option, $option_value);
+#------------------------------------------------------------------------------
+# TBD: Enable once all planned features have been implemented and tested.
+#------------------------------------------------------------------------------
+# Temporarily disabled $msg = "the final values for the user controllable settings";
+# Temporarily disabled print_table_user_settings ("verbose", $msg);
+ }
-} #-- End of subroutine find_target_option
+#------------------------------------------------------------------------------
+# 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";
+
+ gp_message ("verbose", $subr_name, "The experiment " . $plural . ":");
+ 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;
+ }
+
+#------------------------------------------------------------------------------
+# Check whether the experiment directories are valid. If not, it is a fatal
+# error.
+# Upon successful return, one directory has been selected to be used in the
+# remainder. This is not always the correct thing to do, but is the same as
+# the original code. In due time this should be addressed though.
+#------------------------------------------------------------------------------
+ ($dir_check_errors, $archive_dir_not_empty, $selected_archive,
+ $elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref);
+
+ if ($dir_check_errors)
+ {
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+ else
+ {
+ gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid");
+ }
+
+ %elf_rats = %{$elf_rats_ref};
+
+#-------------------------------------------------------------------------------
+# 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)
+ {
+ gp_message ("verbose", $subr_name, "The experiment directories are consistent");
+ }
+ else
+ {
+ gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors");
+ }
+
+#------------------------------------------------------------------------------
+# 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"};
+
+ gp_message ("debug", $subr_name, "executable_name = $executable_name");
+ gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
+ gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable");
+
+#------------------------------------------------------------------------------
+# The gp-display-text tool is critical and has to be available in order to proceed.
+#------------------------------------------------------------------------------
+ $ignore_value = check_availability_tool ();
+
+ ($return_code, $decimal_separator, $convert_to_dot) =
+ determine_decimal_separator ();
+
+ if ($return_code == 0)
+ {
+ my $txt = "decimal separator is $decimal_separator " .
+ "(conversion to dot is " .
+ ($convert_to_dot == $TRUE ? "enabled" : "disabled").")";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+ else
+ {
+ my $msg = "the decimal separator can not be determined - set to $decimal_separator";
+ gp_message ("warning", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Collect and store the system information.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Collect system information and adapt settings");
+
+ $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);
+
+ gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported");
+ gp_message ("debug", $subr_name, "elf_arch = $elf_arch");
+ gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE"));
+
+ for my $feature (sort keys %g_arch_specific_settings)
+ {
+ gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}");
+ }
+
+ $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 ();
+
+ gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}");
+
+#------------------------------------------------------------------------------
+# 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;
+ gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
+ gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
+
+ gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found");
+
+ $g_html_credits_line = ${ create_html_credits () };
+ gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line");
+#------------------------------------------------------------------------------
+# 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.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments");
+
+ $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
+#------------------------------------------------------------------------------
+ open (METRICS, "<", $outfile1)
+ or die ("$subr_name - unable to open metric value data 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)
+ {
+ gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]");
+ }
+
+#------------------------------------------------------------------------------
+# 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;
+
+ gp_message ("debugXL", $subr_name, "after the call to process_metrics_data");
+ for my $metric (sort keys %metric_value)
+ {
+ gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}");
+ }
+ for my $metric (sort keys %metric_description)
+ {
+ gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}");
+ }
+ 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.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Select the set of default metrics");
+
+ ($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;
+
+ gp_message ("debug", $subr_name, "after the call to set_default_metrics");
+
+ }
+
+ $number_of_metrics = split (":", $summary_metrics);
+
+ gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics");
+ gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics");
+ gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system");
+ gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics");
+ gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics");
+
+#------------------------------------------------------------------------------
+# TBD Find a way to better handle this situation:
+#------------------------------------------------------------------------------
+ for my $im (keys %metric_found)
+ {
+ gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}");
+ }
+ for my $im (keys %ignored_metrics)
+ {
+ if (not exists ($metric_found{$im}))
+ {
+ gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Get the information on the experiments.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Generate the experiment information");
+
+ my $exp_info_file_ref;
+ my $exp_info_file;
+ my $exp_info_ref;
+ my @exp_info;
+
+ my $experiment_data_ref;
+
+ $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list);
+ my @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.
+#------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Generate the list with functions executed");
+
+ 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.
+#------------------------------------------------------------------------------
+
+ gp_message ("verbose", $subr_name, "Analyze and store the relevant function information");
+
+ ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref,
+ $LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile);
+
+ @function_info = @{ $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 };
+
+ for my $keys (0 .. $#function_info)
+ {
+ for my $fields (keys %{$function_info[$keys]})
+ {
+ gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}");
+ }
+ }
+
+ for my $i (keys %addressobjtextm)
+ {
+ gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}");
+ }
+
+ gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information");
+
+ $script_pc_metrics = generate_function_level_info (\@exp_dir_list,
+ $call_metrics,
+ $summary_metrics,
+ $outputdir,
+ $sort_fields_ref);
+
+ gp_message ("verbose", $subr_name, "Preprocess the files with the function level information");
+
+ $ignore_value = preprocess_function_files (
+ $metric_description_ref,
+ $script_pc_metrics,
+ $outputdir,
+ \@sort_fields);
+
+ gp_message ("verbose", $subr_name, "For each function, generate a set of files");
+
+ ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files (
+ \@exp_dir_list,
+ $executable_name,
+ $time_percentage_multiplier,
+ $summary_metrics,
+ $process_all_functions,
+ $elf_loadobjects_found,
+ $outputdir,
+ \@sort_fields,
+ \@function_info,
+ \%function_address_and_index,
+ \%LINUX_vDSO,
+ \%metric_description,
+ $elf_arch,
+ $base_va_executable,
+ $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats);
+
+ @function_info = @{ $function_info_ref };
+ %function_address_info = %{ $function_address_info_ref };
+ %addressobj_index = %{ $addressobj_index_ref };
+
+#-------------------------------------------------------------------------------------
+# Parse the disassembly information and generate the html files.
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files");
+
+ $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info,
+ \%function_address_and_index,
+ \$outputdir, \%addressobj_index);
+
+#-------------------------------------------------------------------------------------
+# Parse the source information and generate the html files.
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Parse the source files and generate the html files");
+
+ parse_source_files (\$number_of_metrics, \@function_info, \$outputdir);
+
+#-------------------------------------------------------------------------------------
+# Parse the caller-callee information and generate the html files.
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file");
+
+#-------------------------------------------------------------------------------------
+# 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")
+ {
+ my $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);
+ }
+
+#-------------------------------------------------------------------------------------
+# TBD
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Generate the html file with the metrics information");
+
+ $ignore_value = process_metrics (
+ $outputdir,
+ \@sort_fields,
+ \%metric_description,
+ \%ignored_metrics);
+
+#-------------------------------------------------------------------------------------
+# Generate the function view html files.
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Generate the function view html files");
+
+ $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 };
+
+ gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file");
+
+ my $html_test = ${ generate_home_link ("left") };
+ gp_message ("debugXL", $subr_name, "html_test = $html_test");
+
+ my $number_of_warnings_ref = create_html_warnings_page (\$outputdir);
+
+#-------------------------------------------------------------------------------------
+# Generate the index.html file.
+#-------------------------------------------------------------------------------------
+ gp_message ("verbose", $subr_name, "Generate the index.html file");
+
+ $ignore_value = generate_index (\$outputdir,
+ \$html_first_metric_file,
+ \$summary_metrics,
+ \$number_of_metrics,
+ \@function_info,
+ \%function_address_info,
+ \@sort_fields,
+ \@exp_dir_list,
+ \%addressobjtextm,
+ \%metric_description_reversed,
+ $number_of_warnings_ref,
+ \@table_execution_stats);
+
+#-------------------------------------------------------------------------------------
+# We're done. In debug mode, print the meta data for the experiment directories.
+#-------------------------------------------------------------------------------------
+ $ignore_value = print_meta_data_experiments ("debug");
+
+ my $results_file = $abs_path_outputdir . "/index.html";
+ my $prologue_text = "Processing completed - view file $results_file in a browser";
+ gp_message ("diag", $subr_name, $prologue_text);
+
+ return (0);
+
+} #-- End of subroutine main
+
+#------------------------------------------------------------------------------
+# Print a message after a failure in $GP_DISPLAY_TEXT.
+#------------------------------------------------------------------------------
+sub msg_display_text_failure
+{
+ my $subr_name = get_my_name ();
+
+ my ($gp_display_text_cmd, $error_code, $error_file) = @_;
+
+ my $msg;
+
+ $msg = "error code = $error_code - failure executing the following command:";
+ gp_message ("error", $subr_name, $msg);
+
+ gp_message ("error", $subr_name, $gp_display_text_cmd);
+
+ $msg = "check file $error_file for more details";
+ gp_message ("error", $subr_name, $msg);
+
+ return (0);
+
+} #-- End of subroutine msg_display_text_failure
+
+#------------------------------------------------------------------------------
+# 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 $number_of_fields;
+ my $raw_hex_branch_target;
+ my $result;
+
+ if ($g_addressing_mode eq "64 bit")
+ {
+ $mask = "0xffffffffffffffff";
+ $number_of_fields = 16;
+ }
+ else
+ {
+ gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n");
+ }
+
+ $length_of_string = length ($instruction_offset);
+ $first_char = lcfirst (substr ($instruction_offset,0,1));
+ $d1 = hex ($instruction_offset);
+ $d2 = 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 = hex ($instruction_address) - $result;
+ }
+ else
+ {
+ $result = $d1;
+ $dec_branch_target = 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
+
+#------------------------------------------------------------------------------
+# This subroutine sets the absolute path to all commands in array @cmds. The
+# commands and their respective paths are stored in hash "g_mapped_cmds".
+#
+# It is a fatal error if such a path can't be found.
+#------------------------------------------------------------------------------
+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 $found_match;
+ my $target_cmd;
+ my $failed_cmd;
+ my $no_of_failed_mappings;
+ my $failed_cmds;
+
+ gp_message ("debug", $subr_name, "\@cmds = @cmds");
+ gp_message ("debug", $subr_name, "\@search_path = @search_path");
+
+#------------------------------------------------------------------------------
+# Search for the command to be in the search path given. In case no such path
+# can be found, the entry in $g_mapped_cmds is assigned a special value that
+# will be checked for in the next block.
+#------------------------------------------------------------------------------
+ for my $cmd (@cmds)
+ {
+ $found_match = $FALSE;
+ for my $path (@search_path)
+ {
+ $target_cmd = $path."/".$cmd;
+ if (-x $target_cmd)
+ {
+ $found_match = $TRUE;
+ $g_mapped_cmds{$cmd} = $target_cmd;
+ last;
+ }
+ }
+
+ if (not $found_match)
+ {
+ $g_mapped_cmds{$cmd} = "road_to_nowhere";
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Scan the results stored in $g_mapped_cmds and flag errors.
+#------------------------------------------------------------------------------
+ $no_of_failed_mappings = 0;
+ $failed_cmds = "";
+ while ( my ($cmd, $mapped) = each %g_mapped_cmds)
+ {
+ if ($mapped eq "road_to_nowhere")
+ {
+ gp_message ("error", $subr_name, "cannot find a path for command $cmd");
+ $no_of_failed_mappings++;
+ $failed_cmds .= $cmd;
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "path for the $cmd command is $mapped");
+ }
+ }
+ if ($no_of_failed_mappings != 0)
+ {
+ gp_message ("error", $subr_name, "failed to find a mapping for $failed_cmds");
+ gp_message ("error", $subr_name, "a total of $no_of_failed_mappings mapping failures");
+ }
+
+ 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;
+ gp_message ("debug", $subr_name, "cannot determine branch target");
+ }
+ }
+ 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}" .
+ " = $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 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.
+#------------------------------------------------------------------------------
+sub check_availability_tool
+{
+ my $subr_name = get_my_name ();
+
+ my $target_cmd;
+ my $output_which_gp_display_text;
+ my $error_code;
+
+ $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)
+ {
+ gp_message ("debug", $subr_name, "tool $GP_DISPLAY_TEXT is in the search path");
+ }
+ else
+ {
+ gp_message ("abort", $subr_name, "fatal error executing command $target_cmd");
+ }
+
+ return (0);
+
+} #-- 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 $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 $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.
+#------------------------------------------------------------------------------
+ open (LOG_XML, "<", $path_to_log_file)
+ or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'");
+ gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading");
+
+ while (<LOG_XML>)
+ {
+ $line = $_;
+ chomp ($line);
+ gp_message ("debug", $subr_name, "read line: $line");
+#------------------------------------------------------------------------------
+# Search for the first line starting with "<system". Bail out if found and
+# parsed. These are two examples:
+# <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514">
+# <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968">
+#------------------------------------------------------------------------------
+ if ($line =~ /^\s*<system\s+/)
+ {
+ gp_message ("debug", $subr_name, "selected the following line from the log.xml file:");
+ gp_message ("debug", $subr_name, "$line");
+ if ($line =~ /.*\s+hostname="([^"]+)/)
+ {
+ $hostname_exp = $1;
+ gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp");
+ }
+ if ($line =~ /.*\s+arch="([^"]+)/)
+ {
+ $arch_exp = $1;
+ gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp");
+ }
+ if ($line =~ /.*\s+os="([^"]+)/)
+ {
+ $os_exp_full = $1;
+#------------------------------------------------------------------------------
+# Capture the first word only.
+#------------------------------------------------------------------------------
+ if ($os_exp_full =~ /([^\s]+)/)
+ {
+ $os_exp = $1;
+ }
+ gp_message ("debug", $subr_name, "extracted os_exp = $os_exp");
+ }
+ 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))
+ {
+ gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system");
+ gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE");
+# FAKE return ($TRUE);
+ }
+
+ if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"})
+ {
+ gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
+ for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}})
+ {
+ gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# 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"})
+ {
+ gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format");
+ gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML");
+## return ($TRUE);
+ }
+
+ gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format");
+
+ $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
+ $path_to_map_file .= $selected_archive;
+ $path_to_map_file .= "/map.xml";
+
+ open (MAP_XML, "<", $path_to_map_file)
+ or die ($subr_name, "unable to open file $path_to_map_file for reading: $!");
+ gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading");
+
+#------------------------------------------------------------------------------
+# 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 ("debug", $subr_name, "MAP_XML read line = $line");
+## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
+ if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
+ {
+ gp_message ("debug", $subr_name, "target line = $line");
+ $vaddr = $1;
+ $foffset = $2;
+ $modes = $3;
+ $name_path = $4;
+ $name = get_basename ($name_path);
+ gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes");
+ gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name");
+# $error_extracting_information = $TRUE;
+ $executable_name = $name;
+ my $result_VA = hex ($vaddr) - hex ($foffset);
+ my $hex_VA = sprintf ("0x%016x", $result_VA);
+ $va_executable_in_hex = $hex_VA;
+ gp_message ("debug", $subr_name, "set executable_name = $executable_name");
+ gp_message ("debug", $subr_name, "set va_executable_in_hex = $va_executable_in_hex");
+ gp_message ("debug", $subr_name, "result_VA = $result_VA");
+ gp_message ("debug", $subr_name, "hex_VA = $hex_VA");
+ if ($modes eq "005")
+ {
+ $extracted_information = $TRUE;
+ last;
+ }
+ }
+ }
+ if (not $extracted_information)
+ {
+ my $msg = "cannot find the necessary information in 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 $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];
+ gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
+ if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) )
+ {
+# TBD: abs needed?
+ gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
+ $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
+ gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance");
+ if ($relative_distance >= $hp_value/100.0)
+ {
+ gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
+ $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 if the value for the user option given is valid.
+#
+# In case the value is valid, the g_user_settings table is updated.
+# Otherwise an error message is printed.
+#
+# The return value is TRUE/FALSE.
+#------------------------------------------------------------------------------
+sub check_user_option
+{
+ my $subr_name = get_my_name ();
+
+ my ($internal_option_name, $value) = @_;
+
+ my $message;
+ my $return_value;
+
+ my $option = $g_user_settings{$internal_option_name}{"option"};
+ my $data_type = $g_user_settings{$internal_option_name}{"data_type"};
+ my $no_of_arguments = $g_user_settings{$internal_option_name}{"no_of_arguments"};
+
+ if (($no_of_arguments >= 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.
+#------------------------------------------------------------------------------
+
+ $message = "the $option option requires a value";
+ push (@g_user_input_errors, $message);
+ $return_value = $FALSE;
+ }
+ elsif ($no_of_arguments >= 1)
+ {
+#------------------------------------------------------------------------------
+# 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.
+#------------------------------------------------------------------------------
+ my $valid = verify_if_input_is_valid ($value, $data_type);
+
+ if ($valid)
+ {
+ if (($data_type eq "onoff") or ($data_type eq "size"))
+ {
+ $g_user_settings{$internal_option_name}{"current_value"} = lc ($value);
+ }
+ else
+ {
+ $g_user_settings{$internal_option_name}{"current_value"} = $value;
+ }
+ $g_user_settings{$internal_option_name}{"defined"} = $TRUE;
+ $return_value = $TRUE;
+ }
+ else
+ {
+ $message = "incorrect value for $option option: $value";
+ push (@g_user_input_errors, $message);
+
+ $return_value = $FALSE;
+ }
+ }
+
+ return ($return_value);
+
+} #-- End of subroutine check_user_option
+
+#-------------------------------------------------------------------------------
+# This subroutine performs multiple checks on the experiment directories. One
+# or more failures are fatal.
+#-------------------------------------------------------------------------------
+sub check_validity_exp_dirs
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my %elf_rats = ();
+
+ my $dir_not_found = $FALSE;
+ my $invalid_dir = $FALSE;
+ my $dir_check_errors = $FALSE;
+ my $missing_dirs = 0;
+ my $invalid_dirs = 0;
+
+ my $archive_dir_not_empty;
+ my $elf_magic_number;
+ my $archives_file;
+ my $archives_dir;
+ my $first_line;
+ my $count_exp_dir_not_elf;
+
+ 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;
+
+#-------------------------------------------------------------------------------
+# Check if the experiment directories exist and are valid.
+#-------------------------------------------------------------------------------
+ for my $exp_dir (@exp_dir_list)
+ {
+ if (not -d $exp_dir)
+ {
+ $dir_not_found = $TRUE;
+ $missing_dirs++;
+ gp_message ("error", $subr_name, "directory $exp_dir not found");
+ $dir_check_errors = $TRUE;
+ }
+ else
+ {
+#-------------------------------------------------------------------------------
+# Files log.xml and map.xml have to be there.
+#-------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "directory $exp_dir found");
+ if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml"))
+ {
+ gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory");
+ }
+ else
+ {
+ $invalid_dir = $TRUE;
+ $invalid_dirs++;
+ gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing");
+ gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory");
+ $dir_check_errors = $TRUE;
+ }
+ }
+ }
+ if ($dir_not_found)
+ {
+ gp_message ("error", $subr_name, "a total of $missing_dirs directories not found");
+ }
+ if ($invalid_dir)
+ {
+ gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid");
+ }
+
+#-------------------------------------------------------------------------------
+# Initialize ELF status to FALSE.
+#-------------------------------------------------------------------------------
+## for my $exp_dir (@exp_dir_list)
+ for my $exp_dir (keys %g_exp_dir_meta_data)
+ {
+ $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
+ }
+#-------------------------------------------------------------------------------
+# Check if the load objects are in ELF format.
+#-------------------------------------------------------------------------------
+ for my $exp_dir (keys %g_exp_dir_meta_data)
+ {
+ $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives";
+ $archive_dir_not_empty = $FALSE;
+ $first_time = $TRUE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE;
+ $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0;
+
+ gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
+ gp_message ("debug", $subr_name, "checking $archives_dir");
+
+ while (glob ("$archives_dir/*"))
+ {
+ $filename = get_basename ($_);
+ gp_message ("debug", $subr_name, "processing file: $filename");
+
+ $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE;
+ $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++;
+
+ $archive_dir_not_empty = $TRUE;
+#-------------------------------------------------------------------------------
+# Replaces the ELF_RATS part in elf_phdr.
+#
+# Challenge: splittable_mrg.c_I0txnOW_Wn5
+#
+# TBD: Store this for each relevant experiment directory.
+#-------------------------------------------------------------------------------
+ my $last_dot = rindex ($filename,".");
+ my $underscore_before_dot = $TRUE;
+ my $first_underscore = -1;
+ gp_message ("debugXL", $subr_name, "last_dot = $last_dot");
+ 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);
+ gp_message ("debug", $subr_name, "stripped archive name: $original_name");
+ if (not exists ($elf_rats{$original_name}))
+ {
+ $elf_rats{$original_name} = [$filename, $exp_dir];
+ }
+#-------------------------------------------------------------------------------
+# We only need to detect the presence of an object once.
+#-------------------------------------------------------------------------------
+ if ($first_time)
+ {
+ $first_time = $FALSE;
+ $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE;
+ gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
+ }
+ }
+ } #-- End of loop over experiment directories
+
+ for my $exp_dir (sort keys %g_exp_dir_meta_data)
+ {
+ my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
+ gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty"));
+ }
+
+#------------------------------------------------------------------------------
+# 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"} . $exp_dir . "/archives";
+ gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir");
+#------------------------------------------------------------------------------
+# 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"} . $exp_dir . "/archives/" . $aname;
+ open (ARCF,"<", $filename)
+ or die ("unable to open file $filename for reading - '$!'");
+
+ $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);
+# gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number");
+ if ($elf_magic_number eq "7f454c46")
+ {
+ $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE;
+ $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE;
+ last;
+ }
+ }
+ }
+ }
+
+ for my $exp_dir (sort keys %g_exp_dir_meta_data)
+ {
+ $comment = "the loadobjects in the archive in $exp_dir are ";
+ $comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in ";
+ $comment .= "ELF format";
+ gp_message ("debug", $subr_name, $comment);
+ }
+ for my $exp_dir (sort keys %g_exp_dir_meta_data)
+ {
+ if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
+ {
+ gp_message ("debug", $subr_name, "there are no archived files in $exp_dir");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# If there are archived files and they are not in ELF format, a debug 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)
+ {
+ gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects");
+ }
+
+#------------------------------------------------------------------------------
+# 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)
+ {
+ gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir");
+ gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
+
+ 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;
+ }
+ }
+ }
+ gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis");
+ gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty"));
+ gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format");
+#------------------------------------------------------------------------------
+# Get the size of the hash that contains the archived files.
+#------------------------------------------------------------------------------
+## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES);
+
+ $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"};
+ gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive");
+
+
+ for my $exp_dir (sort keys %g_exp_dir_meta_data)
+ {
+ my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
+ gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty"));
+ }
+ 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"}})
+ {
+ gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}[...]
[diff truncated at 100000 bytes]
reply other threads:[~2022-07-06 21:59 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20220706215945.B17DC3858D28@sourceware.org \
--to=vmezents@sourceware.org \
--cc=bfd-cvs@sourceware.org \
--cc=gdb-cvs@sourceware.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).