-#!/usr/bin/perl
-
+#!/usr/bin/env perl
# Copyright (C) 2021 Free Software Foundation, Inc.
# Contributed by Oracle.
#
# 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.
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}{'archive_files'}{$object}");
+ }
+ }
+ }
+
+ return ($dir_check_errors, $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 $plural;
+
+ $plural = ($#experiment_dir_list > 0) ? "s:" : ":";
+
+ $experiment_stats_line = "<h3>\n";
+ $experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n";
+ $experiment_stats_line .= "</h3>\n";
+ $experiment_stats_line .= "<pre>\n";
+
+ for my $i (0 .. $#experiment_dir_list)
+ {
+ $experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n";
+ }
+ $experiment_stats_line .= "</pre>\n";
+
+ push (@experiment_stats_html, $experiment_stats_line);
+
+ gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --");
+
+ 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\" 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 an HTML page with the warnings. If there are no warnings, include
+# line to this extent. The alternative is to supporess the entire page, but
+# that breaks the consistency in the output.
+#------------------------------------------------------------------------------
+sub create_html_warnings_page
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+
+ my $file_title;
+ my $html_acknowledgement;
+ my $html_end;
+ my $html_header;
+ my $html_home_left;
+ my $html_home_right;
+ my $html_title_header;
+ my $msg_no_warnings = "There are no warning messages issued.";
+ my $page_title;
+ my $position_text;
+ my $size_text;
+
+ my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html";
+
+ gp_message ("debug", $subr_name, "outfile = $outfile");
+
+ open (WARNINGS_OUT, ">", $outfile)
+ or die ("unable to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ gp_message ("debug", $subr_name, "building warning file $outfile");
+
+#------------------------------------------------------------------------------
+# Get the number of warnings and in debug mode, print the list.
+#------------------------------------------------------------------------------
+ my $number_of_warnings = scalar (@g_warning_messages);
+ gp_message ("debug", $subr_name, "number_of_warnings = $number_of_warnings");
+
+ if ($number_of_warnings > 0)
+ {
+ for my $i (0 .. $#g_warning_messages)
+ {
+ print "$g_warning_messages[$i]\n";
+ my $msg = "g_warning_messages[$i] = $g_warning_messages[$i]";
+ gp_message ("debug", $subr_name, $msg);
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Generate some of the structures used in the HTML output.
+#------------------------------------------------------------------------------
+ $file_title = "Warning messages";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home_right = ${ generate_home_link ("right") };
+
+ $page_title = "Warning Messages";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+#-------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#-------------------------------------------------------------------------------
+ $html_home_left = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
+#-------------------------------------------------------------------------------
+# Generate the HTML file.
+#-------------------------------------------------------------------------------
+ print WARNINGS_OUT $html_header;
+ print WARNINGS_OUT $html_home_right;
+ print WARNINGS_OUT $html_title_header;
+
+ if ($number_of_warnings > 0)
+ {
+ print WARNINGS_OUT "<pre>\n";
+ print WARNINGS_OUT "$_\n" for @g_warning_messages;
+ print WARNINGS_OUT "</pre>\n";
+ }
+ else
+ {
+ print WARNINGS_OUT $msg_no_warnings;
+ }
+
+ print WARNINGS_OUT $html_home_left;
+ print WARNINGS_OUT "<br>\n";
+ print WARNINGS_OUT $html_acknowledgement;
+ print WARNINGS_OUT $html_end;
+
+ close (WARNINGS_OUT);
+
+ return (\$number_of_warnings);
+
+} #-- End of subroutine create_html_warnings_page
+
+#-------------------------------------------------------------------------------
+# Create a complete table.
+#-------------------------------------------------------------------------------
+sub create_table
+{
+ my $subr_name = get_my_name ();
+
+ my ($experiment_data_ref, $table_definition_ref) = @_;
+
+ my @experiment_data = @{ $experiment_data_ref };
+ my @table_definition = @{ $table_definition_ref };
+
+ 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 };
+
+ gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key");
+
+ my $html_line;
+
+ $html_line = "<tr><div class=\"left\"><td><b> ";
+ $html_line = "<tr><div class=\"right\"><td><b> ";
+ $html_line .= $entry_name;
+ $html_line .= " </b></td>";
+ for my $i (sort keys @experiment_data)
+ {
+ if (exists ($experiment_data[$i]{$key}))
+ {
+ $html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>";
+ }
+ else
+ {
+## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist");
+ gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist");
+ }
+ }
+ $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;
+
+ $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> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>";
+ }
+ $html_header_line .= "</div></tr>\n";
+
+ gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line");
+
+ 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 $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)
+ {
+ gp_message ("error", $subr_name, "directory $outputdir already exists");
+ gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory");
+ }
+#-------------------------------------------------------------------------------
+# 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);
+ gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "directory $outputdir has been removed");
+ }
+ }
+ }
+#-------------------------------------------------------------------------------
+# When we get here, the fatal scenarios have been cleared and the name for
+# $outputdir is known. Time to create it.
+#-------------------------------------------------------------------------------
+ if (mkdir ($outputdir, 0777))
+ {
+ gp_message ("debug", $subr_name, "created output directory $outputdir");
+ }
+ else
+ {
+ gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir");
+ }
+
+ 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 $name_loadobject;
+ my $base_va_address;
+
+ gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable");
+ gp_message ("debugXL", $subr_name, "loadobj = $loadobj");
+ gp_message ("debugXL", $subr_name, "routine = $routine");
+
+#------------------------------------------------------------------------------
+# Strip the pathname from the load object name.
+#------------------------------------------------------------------------------
+ $name_loadobject = get_basename ($loadobj);
+
+#------------------------------------------------------------------------------
+# If the load object is the executable, return the base address determined
+# earlier. Otherwise return 0x0. Note that I am not sure if this is always
+# the right thing to do, but for .so files it seems to work out fine.
+#------------------------------------------------------------------------------
+ if ($name_loadobject eq $executable_name)
+ {
+ $base_va_address = $base_va_executable;
+ }
+ else
+ {
+ $base_va_address = "0x0";
+ }
+
+ my $decimal_address = hex ($base_va_address);
+ gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)");
+
+ return ($base_va_address);
+
+} #-- End of subroutine determine_base_va_address
+
+#-------------------------------------------------------------------------------
+# Now that we know the map.xml file(s) are present, we can scan these and get
+# the required information.
+#-------------------------------------------------------------------------------
+sub determine_base_virtual_address
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my $full_path_exec;
+ my $executable_name;
+ my $va_executable_in_hex;
+
+ my $path_to_map_file;
+
+ for my $exp_dir (keys %g_exp_dir_meta_data)
+ {
+ $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
+ $path_to_map_file .= $exp_dir;
+ $path_to_map_file .= "/map.xml";
+
+ ($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file);
+
+ $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec;
+ $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name;
+ $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex;
+
+ gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
+ gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec");
+ gp_message ("debug", $subr_name, "executable_name = $executable_name");
+ gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+ }
+
+ return (0);
+
+} #-- End of subroutine determine_base_virtual_address
+
+#------------------------------------------------------------------------------
+# Determine whether the decimal separator is a point or a comma.
+#------------------------------------------------------------------------------
+sub determine_decimal_separator
+{
+ my $subr_name = get_my_name ();
+
+ my $ignore_count;
+ my $decimal_separator;
+ my $convert_to_dot;
+ my $field;
+ my $target_found;
+ my $error_code;
+ my $cmd_output;
+ my $target_cmd;
+ my @locale_info;
+
+ my $default_decimal_separator = "\\.";
+
+ $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC";
+ ($error_code, $cmd_output) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+#-------------------------------------------------------------------------------
+# This is unlikely to happen, but you never know. To reduce the nesting level,
+# return right here in case of an error.
+#-------------------------------------------------------------------------------
+ {
+ gp_message ("error", $subr_name, "failure to execute the command $target_cmd");
+
+ $convert_to_dot = $TRUE;
+
+ return ($error_code, $default_decimal_separator, $convert_to_dot);
+ }
+
+#-------------------------------------------------------------------------------
+# Scan the locale info and search for the target line of the form
+# decimal_point="<target>" where <target> is either a dot, or a comma.
+#-------------------------------------------------------------------------------
+
+#-------------------------------------------------------------------------------
+# Split the output into the different lines and scan for the line we need.
+#-------------------------------------------------------------------------------
+ @locale_info = split ("\n", $cmd_output);
+ $target_found = $FALSE;
+ for my $line (@locale_info)
+ {
+ chomp ($line);
+ gp_message ("debug", $subr_name, "line from locale_info = $line");
+ if ($line =~ /decimal_point=/)
+ {
+
+#-------------------------------------------------------------------------------
+# Found the target line. Split this line to get the value field.
+#-------------------------------------------------------------------------------
+ my @split_line = split ("=", $line);
+
+#-------------------------------------------------------------------------------
+# There should be 2 fields. If not, something went wrong.
+#-------------------------------------------------------------------------------
+ if (scalar @split_line != 2)
+ {
+# if (scalar @split_line == 2) {
+# $target_found = $FALSE;
+#-------------------------------------------------------------------------------
+# Remove the newline before printing the variables.
+#-------------------------------------------------------------------------------
+ $ignore_count = chomp ($line);
+ $ignore_count = chomp (@split_line);
+ gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format");
+ gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields");
+ gp_message ("debug", $subr_name, "warning - the default decimal separator will be used");
+ }
+ else
+ {
+#-------------------------------------------------------------------------------
+# We know there are 2 fields and the second one has the decimal point.
+#-------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]");
+
+ chomp ($split_line[1]);
+ $field = $split_line[1];
+
+ if (length ($field) != 3)
+#-------------------------------------------------------------------------------
+# The field still includes the quotes. Check if the string has length 3, which
+# should be the case, but if not, we flag an error. The error code is set such
+# that the callee will know a problem has occurred.
+#-------------------------------------------------------------------------------
+ {
+ gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field");
+ $error_code = 1;
+ last;
+ }
+
+ gp_message ("debug", $subr_name, "field = ->$field<-");
+
+ if (($field eq "\".\"") or ($field eq "\",\""))
+#-------------------------------------------------------------------------------
+# Found the separator. Capture the character between the quotes.
+#-------------------------------------------------------------------------------
+ {
+ $target_found = $TRUE;
+ $decimal_separator = substr ($field,1,1);
+ gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop");
+ last;
+ }
+ }
+ }
+ }
+ if (not $target_found)
+ {
+ $decimal_separator = $default_decimal_separator;
+ gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator");
+ }
+
+ if ($decimal_separator ne ".")
+ {
+ $convert_to_dot = $TRUE;
+ }
+ else
+ {
+ $convert_to_dot = $FALSE;
+ }
+
+ $decimal_separator = "\\".$decimal_separator;
+ $g_locale_settings{"decimal_separator"} = $decimal_separator;
+ $g_locale_settings{"convert_to_dot"} = $convert_to_dot;
+
+ return ($error_code, $decimal_separator, $convert_to_dot);
+
+} #-- End of subroutine determine_decimal_separator
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub dump_function_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($function_info_ref, $name) = @_;
+
+ my %function_info = %{$function_info_ref};
+ my $kip;
+
+ gp_message ("debug", $subr_name, "function_info for $name");
+ $kip = 0;
+ for my $farray ($function_info{$name})
+ {
+ for my $elm (@{$farray})
+ {
+ gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}");
+ for my $key (sort keys %{$elm})
+ {
+ if ($key eq "routine")
+ {
+ next;
+ }
+ gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}");
+ }
+ $kip++;
+ }
+ }
+
+ return (0);
+
+} #-- End of subroutine dump_function_info
+
+#------------------------------------------------------------------------------
+# This is an early scan to find the settings for some options very early on.
+# For practical reasons the main option parsing and handling is done later,
+# but without this early scan, these options will not be enabled until later
+# in the execution.
+#
+# This early scan fixes that, but it is not very elegant to do it this way
+# and in the future, this will be improved. For now it gets the job done.
+#------------------------------------------------------------------------------
+sub early_scan_specific_options
+{
+ my $subr_name = get_my_name ();
+
+ my @options_with_value = qw /verbose warnings debug quiet/;
+ my $target_option;
+
+ my $ignore_value;
+ my $found_option;
+ my $option_requires_value;
+ my $option_value;
+ my $valid_input;
+ my @error_messages = ();
+
+ $option_requires_value = $TRUE;
+ for (@options_with_value)
+ {
+ $target_option = $_;
+ ($found_option, $option_value) = find_target_option (
+ \@ARGV,
+ $option_requires_value,
+ $target_option);
+ if ($found_option)
+ {
+#------------------------------------------------------------------------------
+# This part has been set up such that we can support other options too, should
+# this become necessary.
+#
+# A necessary, but limited check for the validity of a value is performed.
+# This avoids that an error message shows up twice later on.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# All option values are converted to lower case. This makes the checks easier.
+#------------------------------------------------------------------------------
+
+ if ($target_option eq "verbose")
+ {
+ my $verbose_value = lc ($option_value);
+ $valid_input = verify_if_input_is_valid ($verbose_value, "onoff");
+ if ($valid_input)
+ {
+ $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
+ if ($verbose_value eq "on")
+#------------------------------------------------------------------------------
+# Set the status and disable output buffering in verbose mode.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{"verbose"}{"current_value"} = "on";
+ STDOUT->autoflush (1);
+ }
+ elsif ($verbose_value eq "off")
+ {
+ $g_user_settings{"verbose"}{"current_value"} = "off";
+ }
+ }
+ else
+ {
+ my $msg = "$option_value is not supported for the verbose option";
+ push (@error_messages, $msg);
+ }
+ }
+ elsif ($target_option eq "warnings")
+ {
+ my $warnings_value = lc ($option_value);
+ $valid_input = verify_if_input_is_valid ($warnings_value, "onoff");
+ if ($valid_input)
+ {
+ $g_warnings = ($warnings_value eq "on") ? $TRUE : $FALSE;
+ if ($warnings_value eq "on")
+#------------------------------------------------------------------------------
+# Set the status and disable output buffering if warnings are enabled.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{"warnings"}{"current_value"} = "on";
+ STDOUT->autoflush (1);
+ }
+ elsif ($warnings_value eq "off")
+ {
+ $g_user_settings{"warnings"}{"current_value"} = "off";
+ }
+ }
+ else
+ {
+ my $msg = "$option_value is not supported for the warnings option";
+ push (@error_messages, $msg);
+ }
+ }
+ elsif ($target_option eq "quiet")
+ {
+ my $quiet_value = lc ($option_value);
+ $valid_input = verify_if_input_is_valid ($option_value, "onoff");
+ if ($valid_input)
+ {
+ $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
+ if ($quiet_value eq "on")
+ {
+ $g_user_settings{"quiet"}{"current_value"} = "on";
+ }
+ elsif ($quiet_value eq "off")
+ {
+ $g_user_settings{"quiet"}{"current_value"} = "off";
+ }
+ }
+ else
+ {
+ my $msg = "$option_value is not supported for the quiet option";
+ push (@error_messages, $msg);
+ }
+ }
+ elsif ($target_option eq "debug")
+ {
+ my $debug_value = lc ($option_value);
+ $valid_input = verify_if_input_is_valid ($debug_value, "size");
+ if ($valid_input)
+ {
+ if ($debug_value ne "off")
+#------------------------------------------------------------------------------
+# Disable output buffering in debug mode.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{"debug"}{"current_value"} = "on";
+ STDOUT->autoflush (1);
+ }
+#------------------------------------------------------------------------------
+# This function also sets $g_user_settings{"debug"}{"current_value"}.
+#------------------------------------------------------------------------------
+ my $ignore_value = set_debug_size (\$debug_value);
+ }
+ else
+ {
+ my $msg = "$option_value is not supported for the debug option";
+ push (@error_messages, $msg);
+ }
+ }
+ else
+ {
+ my $msg = "target option $target_option not expected";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Check for input errors.
+#------------------------------------------------------------------------------
+ my $input_errors = scalar (@error_messages);
+ if ($input_errors > 0)
+ {
+ my $plural = ($input_errors == 1) ?
+ "is one error" : "are $input_errors errors";
+ print "There " . $plural . " in the options:\n";
+ for my $i (0 .. $#error_messages)
+ {
+ print "- $error_messages[$i]\n";
+ }
+ exit (0);
+ }
+#------------------------------------------------------------------------------
+# If quiet mode has been enabled, disable verbose, warnings and debug.
+#------------------------------------------------------------------------------
+ if ($g_quiet)
+ {
+ $g_user_settings{"verbose"}{"current_value"} = "off";
+ $g_user_settings{"warnings"}{"current_value"} = "off";
+ $g_user_settings{"debug"}{"current_value"} = "off";
+ $g_verbose = $FALSE;
+ $g_warnings = $FALSE;
+ my $debug_off = "off";
+ my $ignore_value = set_debug_size (\$debug_off);
+ }
+
+ return (0);
+
+} #-- End of subroutine early_scan_specific_options
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub elf_phdr
+{
+ my $subr_name = get_my_name ();
+
+ my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine,
+ $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
+
+ my %elf_rats = %{$elf_rats_ref};
+
+ my $return_value;
+
+#------------------------------------------------------------------------------
+# TBD. Quick check. Can be moved up the call tree.
+#------------------------------------------------------------------------------
+ if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") )
+ {
+ gp_message ("abort", $subr_name, "$elf_arch is not a supported OS");
+ }
+
+#------------------------------------------------------------------------------
+# TBD: This should not be in a loop over $loadobj and only use the executable.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# TBD: $routine is not really used in these subroutines. Is this a bug?
+#------------------------------------------------------------------------------
+ if ($elf_loadobjects_found)
+ {
+ gp_message ("debugXL", $subr_name, "calling elf_phdr_usual");
+ $return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats);
+ }
+ else
+ {
+ gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes");
+ $return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR);
+ }
+
+ gp_message ("debug", $subr_name, "the return value = $return_value");
+
+ if (not $return_value)
+ {
+ gp_message ("abort", $subr_name, "need to handle a return value of FALSE");
+ }
+ return ($return_value);
+
+} #-- End of subroutine elf_phdr
+
+#------------------------------------------------------------------------------
+# Return the virtual address for the load object.
+#------------------------------------------------------------------------------
+sub elf_phdr_sometimes
+{
+ my $subr_name = get_my_name ();
+
+ my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME,
+ $ARCHIVES_MAP_VADDR) = @_;
+
+ my $arch_uname_s = $local_system_config{"kernel_name"};
+ my $arch_uname = $local_system_config{"processor"};
+ my $arch = $g_arch_specific_settings{"arch"};
+
+ gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s");
+ gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
+ gp_message ("debug", $subr_name, "arch = $arch");
+
+ my $target_cmd;
+ my $command_string;
+ my $error_code;
+ my $cmd_output;
+
+ my $line;
+ my $blo;
+
+ my $elf_offset;
+ my $i;
+ my @foo;
+ my $foo;
+ my $foo1;
+ my $p_vaddr;
+ my $rc;
+ my $archives_file;
+ my $loadobj_SAVE;
+ my $Offset;
+ my $VirtAddr;
+ my $PhysAddr;
+ my $FileSiz;
+ my $MemSiz;
+ my $Flg;
+ my $Align;
+
+ if ($ARCHIVES_MAP_NAME eq $blo)
+ {
+ return ($ARCHIVES_MAP_VADDR);
+ }
+ else
+ {
+ return ($FALSE);
+ }
+
+ if ($arch_uname_s ne $elf_arch)
+ {
+#------------------------------------------------------------------------------
+# We are masquerading between systems, must leave
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
+ return ($FALSE);
+ }
+ if ($loadobj eq "DYNAMIC_FUNCTIONS")
+#------------------------------------------------------------------------------
+# Linux vDSO, leave for now
+#------------------------------------------------------------------------------
+ {
+ return ($FALSE);
+ }
+
+# TBD: STILL NEEDED??!!
+
+ $loadobj_SAVE = $loadobj;
+
+ $blo = get_basename ($loadobj);
+ gp_message ("debug", $subr_name, "loadobj = $loadobj");
+ gp_message ("debug", $subr_name, "blo = $blo");
+ gp_message ("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
+ gp_message ("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
+ if ($ARCHIVES_MAP_NAME eq $blo)
+ {
+ return ($ARCHIVES_MAP_VADDR);
+ }
+ else
+ {
+ return ($FALSE);
+ }
+
+} #-- End of subroutine elf_phdr_sometimes
+
+#------------------------------------------------------------------------------
+# Return the virtual address for the load object.
+#
+# Note that at this point, $elf_arch is known to be supported.
+#------------------------------------------------------------------------------
+sub elf_phdr_usual
+{
+ my $subr_name = get_my_name ();
+
+ my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_;
+
+ my %elf_rats = %{$elf_rats_ref};
+
+ my $return_code;
+ my $cmd_output;
+ my $target_cmd;
+ my $command_string;
+ my $error_code;
+ my $error_code1;
+ my $error_code2;
+
+ my ($elf_offset, $loadobjARC);
+ my ($i, @foo, $foo, $foo1, $p_vaddr, $rc);
+ my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align);
+
+ my $arch_uname_s = $local_system_config{"kernel_name"};
+
+ gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine");
+
+ my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj);
+ gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj));
+
+ if ($elf_arch eq "Linux")
+ {
+ if ($arch_uname_s ne $elf_arch)
+ {
+#------------------------------------------------------------------------------
+# We are masquerading between systems, must leave.
+# Maybe we could use ELF_RATS
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
+ return ($FALSE);
+ }
+ if ($loadobj eq "DYNAMIC_FUNCTIONS")
+ {
+#------------------------------------------------------------------------------
+# Linux vDSO, leave for now
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "early return: loadobj = $loadobj");
+ return ($FALSE);
+ }
+
+ $target_cmd = $g_mapped_cmds{"readelf"};
+ $command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null";
+
+ ($error_code1, $cmd_output) = execute_system_cmd ($command_string);
+
+ gp_message ("debug", $subr_name, "executed command_string = $command_string");
+ gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
+
+ if ($error_code1 != 0)
+ {
+ gp_message ("debug", $subr_name, "call failure for $command_string");
+#------------------------------------------------------------------------------
+# e.g. $loadobj->/usr/lib64/libc-2.17.so
+#------------------------------------------------------------------------------
+ $loadobjARC = get_basename ($loadobj);
+ gp_message ("debug", $subr_name, "seek elf_rats for $loadobjARC");
+
+ if (exists ($elf_rats{$loadobjARC}))
+ {
+ my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]";
+ $target_cmd = $g_mapped_cmds{"readelf"};
+ $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null";
+ ($error_code2, $cmd_output) = execute_system_cmd ($command_string);
+
+ if ($error_code2 != 0)
+ {
+ gp_message ("abort", $subr_name, "call failure for $command_string");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "executed command_string = $command_string");
+ gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
+ }
+ }
+ else
+ {
+ my $msg = "elf_rats{$loadobjARC} does not exist";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+#------------------------------------------------------------------------------
+# Example output of "readelf -l" on Linux:
+#
+# Elf file type is EXEC (Executable file)
+# Entry point 0x4023a0
+# There are 11 program headers, starting at offset 64
+#
+# Program Headers:
+# Type Offset VirtAddr PhysAddr
+# FileSiz MemSiz Flags Align
+# PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040
+# 0x0000000000000268 0x0000000000000268 R 8
+# INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8
+# 0x000000000000001c 0x000000000000001c R 1
+# [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2]
+# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
+# 0x0000000000001310 0x0000000000001310 R 1000
+# LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000
+# 0x0000000000006515 0x0000000000006515 R E 1000
+# LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000
+# 0x000000000006f5a8 0x000000000006f5a8 R 1000
+# LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
+# 0x000000000000047c 0x0000000000000f80 RW 1000
+# DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8
+# 0x0000000000000220 0x0000000000000220 RW 8
+# NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4
+# 0x0000000000000044 0x0000000000000044 R 4
+# GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4
+# 0x000000000000020c 0x000000000000020c R 4
+# GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000
+# 0x0000000000000000 0x0000000000000000 RW 10
+# GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
+# 0x0000000000000238 0x0000000000000238 R 1
+#
+# Section to Segment mapping:
+# Segment Sections...
+# 00
+# 01 .interp
+# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt
+# 03 .init .plt .text .fini
+# 04 .rodata .eh_frame_hdr .eh_frame
+# 05 .init_array .fini_array .dynamic .got .got.plt .data .bss
+# 06 .dynamic
+# 07 .note.gnu.build-id .note.ABI-tag
+# 08 .eh_frame_hdr
+# 09
+# 10 .init_array .fini_array .dynamic .got
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Analyze the ELF information and try to find the virtual address.
+#
+# Note that the information printed as part of LOAD needs to have "R E" in it.
+# In the example output above, the return value would be "0x0000000000402000".
+#
+# We also need to distinguish two cases. It could be that the output is on
+# a single line, or spread over two lines:
+#
+# Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align
+# LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000
+# or 2 lines
+# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
+# 0x0000000000001010 0x0000000000001010 R E 200000
+#------------------------------------------------------------------------------
+ @foo = split ("\n",$cmd_output);
+ for $i (0 .. $#foo)
+ {
+ $foo = $foo[$i];
+ chomp ($foo);
+ if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
+ {
+ $Offset = $1;
+ $VirtAddr = $2;
+ $PhysAddr = $3;
+ $FileSiz = $4;
+ $MemSiz = $5;
+ $Flg = $6;
+ $Align = $7;
+
+ $elf_offset = $VirtAddr;
+ gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset");
+ return ($elf_offset);
+ }
+ elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/)
+ {
+#------------------------------------------------------------------------------
+# is it a two line version?
+#------------------------------------------------------------------------------
+ $Offset = $1;
+ $VirtAddr = $2; # maybe
+ $PhysAddr = $3;
+ if ($i != $#foo)
+ {
+ $foo1 = $foo[$i + 1];
+ chomp ($foo1);
+ if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
+ {
+ $FileSiz = $1;
+ $MemSiz = $2;
+ $Flg = $3;
+ $Align = $4;
+ $elf_offset = $VirtAddr;
+ gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset");
+ return ($elf_offset);
+ }
+ }
+ }
+ }
+ }
+ elsif ($elf_arch eq "SunOS")
+ {
+#------------------------------------------------------------------------------
+#Program Header[3]:
+# p_vaddr: 0x10000 p_flags: [ PF_X PF_R ]
+# folowed by
+# p_paddr: 0 p_type: [ PT_LOAD ]
+#------------------------------------------------------------------------------
+ if ($arch_uname_s ne $elf_arch)
+#------------------------------------------------------------------------------
+# we are masquerading between systems, must leave
+#------------------------------------------------------------------------------
+ {
+ gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch");
+ return (0);
+ }
+ $target_cmd = $g_mapped_cmds{"elfdump"};
+ $command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null";
+ ($error_code, $cmd_output) = execute_system_cmd ($command_string);
+ if ($error_code != 0)
+ {
+ gp_message ("debug", $subr_name,"call failure for $command_string");
+ die ("$target_cmd call failure");
+ }
+ my @foo = split ("\n",$cmd_output);
+ for $i (0 .. $#foo)
+ {
+ $foo = $foo[$i];
+ chomp ($foo);
+ if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/)
+ {
+ $p_vaddr = $1; # probably
+ if ($i != $#foo)
+ {
+ $foo1 = $foo[$i + 1];
+ chomp ($foo1);
+ if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/)
+ {
+ $elf_offset = $p_vaddr;
+ return ($elf_offset);
+ }
+ }
+ }
+ }
+ }
+
+} #-- End of subroutine elf_phdr_usual
+
+#------------------------------------------------------------------------------
+# Execute a system command. In case of an error, a non-zero error code is
+# returned. It is upon the caller to decide what to do next.
+#------------------------------------------------------------------------------
+sub execute_system_cmd
+{
+ my $subr_name = get_my_name ();
+
+ my ($target_cmd) = @_;
+
+ chomp ($target_cmd);
+
+ my $cmd_output = qx ($target_cmd);
+ my $error_code = ${^CHILD_ERROR_NATIVE};
+
+ if ($error_code != 0)
+ {
+ gp_message ("error", $subr_name, "failure executing command $target_cmd");
+ gp_message ("error", $subr_name, "error code = $error_code");
+ }
+ else
+ {
+ chomp ($cmd_output);
+ gp_message ("debugM", $subr_name, "executed command $target_cmd");
+ gp_message ("debugM", $subr_name, "cmd_output = $cmd_output");
+ }
+
+ return ($error_code, $cmd_output);
+
+} #-- End of subroutine execute_system_cmd
+
+#------------------------------------------------------------------------------
+# Scan the input file, which should be a gprofng generated map.xml file, and
+# extract the relevant information.
+#------------------------------------------------------------------------------
+sub extract_info_from_map_xml
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_map_xml_file) = @_;
+
+ my $extracted_information;
+ my $input_line;
+ my $vaddr;
+ my $foffset;
+ my $modes;
+ my $name_path;
+ my $name;
+
+ my $full_path_exec;
+ my $executable_name;
+ my $va_executable_in_hex;
+
+ open (MAP_XML, "<", $input_map_xml_file)
+ or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!");
+ gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading");
+
+#------------------------------------------------------------------------------
+# Scan the file. We need to find the name of the executable with the mode set
+# to 0x005. For this entry we have to capture the name, the mode, the virtual
+# address and the offset.
+#------------------------------------------------------------------------------
+ $extracted_information = $FALSE;
+ while (<MAP_XML>)
+ {
+ $input_line = $_;
+ chomp ($input_line);
+ gp_message ("debug", $subr_name, "read input_line = $input_line");
+ if ($input_line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
+ {
+ gp_message ("debug", $subr_name, "target line = $input_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");
+
+#------------------------------------------------------------------------------
+# The base virtual address is calculated as vaddr-foffset. Although Perl
+# handles arithmetic in hex, we take the safe way here. Maybe overkill, but
+# I prefer to be safe than sorry in cases like this.
+#------------------------------------------------------------------------------
+ $full_path_exec = $name_path;
+ $executable_name = $name;
+ my $result_VA = hex ($vaddr) - hex ($foffset);
+ $va_executable_in_hex = sprintf ("0x%016x", $result_VA);
+
+## $ARCHIVES_MAP_NAME = $name;
+## $ARCHIVES_MAP_VADDR = $va_executable_in_hex;
+
+## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
+## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
+ gp_message ("debug", $subr_name, "result_VA = $result_VA");
+ gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+
+#------------------------------------------------------------------------------
+# Stop reading when we found the correct entry.
+#------------------------------------------------------------------------------
+ if ($modes eq "005")
+ {
+ $extracted_information = $TRUE;
+ last;
+ }
+ }
+ } #-- End of while-loop
+
+ if (not $extracted_information)
+ {
+ my $msg = "cannot find the necessary information in file $input_map_xml_file";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec");
+ gp_message ("debug", $subr_name, "executable_name = $executable_name");
+ gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
+
+ return ($full_path_exec, $executable_name, $va_executable_in_hex);
+
+} #-- End of subroutine extract_info_from_map_xml
+
+#------------------------------------------------------------------------------
+# This routine analyzes the metric line and extracts the metric specifics
+# from it.
+# Example input: Exclusive Total CPU Time: e.%totalcpu
+#------------------------------------------------------------------------------
+sub extract_metric_specifics
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric_line) = @_;
+
+ my $metric_description;
+ my $metric_flavor;
+ my $metric_visibility;
+ my $metric_name;
+ my $metric_spec;
+
+# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
+ if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
+ {
+ gp_message ("debug", $subr_name, "line of interest: $metric_line");
+
+ $metric_description = $1;
+ $metric_flavor = $2;
+ $metric_visibility = $3;
+ $metric_name = $4;
+
+#------------------------------------------------------------------------------
+# Although we have captured the metric visibility, the original code removes
+# this from the name. Since the structure is more complicated, the code is
+# more tedious as well. With our new approach we just leave the visibility
+# out.
+#------------------------------------------------------------------------------
+# $metric_spec = $metric_flavor.$metric_visibility.$metric_name;
+
+ $metric_spec = $metric_flavor . "." . $metric_name;
+
+#------------------------------------------------------------------------------
+# From the original code:
+#
+# On x64 systems there are metrics which contain ~ (for example
+# DC_access~umask=0 . When er_print lists them, they come out
+# as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is
+# fixed, we need this. Later we may need something else, or
+# things may just work.
+#------------------------------------------------------------------------------
+# $metric_spec=~s/\%7e\%/,/;
+# # remove % metric
+# print "DB: before \$metric_spec = $metric_spec\n";
+
+#------------------------------------------------------------------------------
+# TBD: I don't know why the "%" symbol is removed.
+#------------------------------------------------------------------------------
+# $metric_spec =~ s/\%//;
+# print "DB: after \$metric_spec = $metric_spec\n";
+
+ return ($metric_spec, $metric_flavor, $metric_visibility,
+ $metric_name, $metric_description);
+ }
+ else
+ {
+ return ("skipped", "void");
+ }
+
+} #-- End of subroutine extract_metric_specifics
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub extract_source_line_number
+{
+ my $subr_name = get_my_name ();
+
+ my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_;
+
+#------------------------------------------------------------------------------
+# The regex section.
+#------------------------------------------------------------------------------
+ my $find_dot_regex = '\.';
+
+ my @fields_in_line = ();
+ my $hot_line;
+ my $line_id;
+
+#------------------------------------------------------------------------------
+# To extract the source line number, we need to distinguish whether this is
+# a line with, or without metrics.
+#------------------------------------------------------------------------------
+ @fields_in_line = split (" ", $input_line);
+ if ( $input_line =~ /$src_times_regex/ )
+ {
+ $hot_line = $1;
+ if ($hot_line eq "##")
+#------------------------------------------------------------------------------
+# The line id comes after the "##" symbol and the metrics.
+#------------------------------------------------------------------------------
+ {
+ $line_id = $fields_in_line[$number_of_metrics+1];
+ }
+ else
+#------------------------------------------------------------------------------
+# The line id comes after the metrics.
+#------------------------------------------------------------------------------
+ {
+ $line_id = $fields_in_line[$number_of_metrics];
+ }
+ }
+ elsif ($input_line =~ /$function_regex/)
+ {
+ $line_id = "func";
+ }
+ else
+#------------------------------------------------------------------------------
+# The line id is the first non-blank element.
+#------------------------------------------------------------------------------
+ {
+ $line_id = $fields_in_line[0];
+ }
+#------------------------------------------------------------------------------
+# Remove the trailing dot.
+#------------------------------------------------------------------------------
+ $line_id =~ s/$find_dot_regex//;
+
+ return ($line_id);
+
+} #-- End of subroutine extract_source_line_number
+
+#------------------------------------------------------------------------------
+# For a give routine name and address, find the index into the
+# function_info array
+#------------------------------------------------------------------------------
+sub find_index_in_function_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($routine_ref, $current_address_ref, $function_info_ref) = @_;
+
+ my $routine = ${ $routine_ref };
+ my $current_address = ${ $current_address_ref };
+ my @function_info = @{ $function_info_ref };
+
+ my $addr_offset;
+ my $ref_index;
+
+ gp_message ("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address");
+ if (exists ($g_multi_count_function{$routine}))
+ {
+
+# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
+
+ gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
+ for my $ref (keys @{ $g_map_function_to_index{$routine} })
+ {
+ $ref_index = $g_map_function_to_index{$routine}[$ref];
+
+ gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
+ gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
+
+ $addr_offset = $function_info[$ref_index]{"addressobjtext"};
+ gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
+
+ $addr_offset =~ s/^@\d+://;
+ gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
+ if ($addr_offset eq $current_address)
+ {
+ last;
+ }
+ }
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# There is only a single occurrence and it is straightforward to get the index.
+#------------------------------------------------------------------------------
+ if (exists ($g_map_function_to_index{$routine}))
+ {
+ $ref_index = $g_map_function_to_index{$routine}[0];
+ }
+ else
+ {
+ my $msg = "index for $routine cannot be determined";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+
+ gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index");
+
+ return (\$ref_index);
+
+} #-- End of subroutine find_index_in_function_info
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub find_keyword_in_string
+{
+ my $subr_name = get_my_name ();
+
+ my ($target_string_ref, $target_keyword_ref) = @_;
+
+ my $target_string = ${ $target_string_ref };
+ my $target_keyword = ${ $target_keyword_ref };
+ my $foundit = $FALSE;
+
+ my @index_values = ();
+
+ my $ret_val = 0;
+ my $offset = 0;
+ gp_message ("debugXL", $subr_name, "target_string = $target_string");
+ $ret_val = index ($target_string, $target_keyword, $offset);
+ gp_message ("debugXL", $subr_name, "ret_val = $ret_val");
+
+ if ($ret_val != -1)
+ {
+ $foundit = $TRUE;
+ while ($ret_val != -1)
+ {
+ push (@index_values, $ret_val);
+ $offset = $ret_val + 1;
+ gp_message ("debugXL", $subr_name, "ret_val = $ret_val offset = $offset");
+ $ret_val = index ($target_string, $target_keyword, $offset);
+ }
+ for my $i (keys @index_values)
+ {
+ gp_message ("debugXL", $subr_name, "index_values[$i] = $index_values[$i]");
+ }
+ }
+ else
+ {
+ gp_message ("debugXL", $subr_name, "target keyword $target_keyword not found");
+ }
+
+ return (\$foundit, \@index_values);
+
+} #-- End of subroutine find_keyword_in_string
+
+#------------------------------------------------------------------------------
+# Scan the command line to see if the specified option is present.
+#
+# Two types of options are supported: options without a value (e.g. --help) or
+# those that are set to "on" or "off".
+#
+# In this phase, we only need to check if a value is valid. If it is, we have
+# to enable the corresponding global setting. If the value is not valid, we
+# ignore it, since it will be caught later and a warning message is issued.
+#------------------------------------------------------------------------------
+sub find_target_option
+{
+ my $subr_name = get_my_name ();
+
+ my ($command_line_ref, $option_requires_value, $target_option) = @_;
+
+ my @command_line = @{ $command_line_ref };
+ my $option_value = undef;
+ my $found_option = $FALSE;
+
+ my ($command_line_string) = join (" ", @command_line);
+
+## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/)
+#------------------------------------------------------------------------------
+# This does not make any assumptions on the values we are looking for.
+#------------------------------------------------------------------------------
+ if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/)
+ {
+ if (defined ($1))
+#------------------------------------------------------------------------------
+# We have found the option we are looking for.
+#------------------------------------------------------------------------------
+ {
+ $found_option = $TRUE;
+ if ($option_requires_value and defined ($2))
+#------------------------------------------------------------------------------
+# There is a value and it is passed on to the caller.
+#------------------------------------------------------------------------------
+ {
+ $option_value = $2;
+ }
+ }
+ }
+
+ return ($found_option, $option_value);
+
+} #-- End of subroutine find_target_option
+
+#------------------------------------------------------------------------------
+# Find the occurrences of non-space characters in a string and return their
+# start and end index values(s).
+#------------------------------------------------------------------------------
+sub find_words_in_line
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_line_ref) = @_;
+
+ my $input_line = ${ $input_line_ref };
+
+ my $finished = $TRUE;
+
+ my $space = 0;
+ my $space_position = 0;
+ my $start_word;
+ my $end_word;
+
+ my @word_delimiters = ();
+
+ gp_message ("debugXL", $subr_name, "input_line = $input_line");
+
+ $finished = $FALSE;
+ while (not $finished)
+ {
+ $space = index ($input_line, " ", $space_position);
+
+ my $txt = "string search space_position = $space_position ";
+ $txt .= "space = $space";
+ gp_message ("debugXL", $subr_name, $txt);
+
+ if ($space != -1)
+ {
+ if ($space > $space_position)
+ {
+ $start_word = $space_position;
+ $end_word = $space - 1;
+ $space_position = $space;
+ my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
+ gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword");
+ push (@word_delimiters, [$start_word, $end_word]);
+ }
+ elsif ( ($space == $space_position) and ($space < length ($input_line) - 1))
+ {
+ $space = $space + 1;
+ $space_position = $space;
+ }
+ else
+ {
+ print "DONE\n";
+ $finished = $TRUE;
+ gp_message ("debugXL", $subr_name, "completed - finished = $finished");
+ }
+ }
+ else
+ {
+ $finished = $TRUE;
+ $start_word = $space_position;
+ $end_word = length ($input_line) - 1;
+ my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
+ push (@word_delimiters, [$start_word, $end_word]);
+ if ($keyword =~ /\s+/)
+ {
+ my $txt = "end search spaces only";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+ else
+ {
+ my $txt = "end search start_word = $start_word ";
+ $txt .= "end_word = $end_word ";
+ $txt .= "space_position = $space_position -->$keyword<--";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+ }
+
+ }
+
+ for my $i (keys @word_delimiters)
+ {
+ gp_message ("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]");
+ }
+
+ return (\@word_delimiters);
+
+} #-- End of subroutine find_words_in_line
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub function_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_;
+
+ my %LINUX_vDSO = %{ $LINUX_vDSO_ref };
+
+ my $index_val;
+ my $address_decimal;
+ my $full_address_field;
+
+ my $FUNC_FILE_NO_PC;
+ my $off_with_the_PC;
+
+ my $blanks;
+ my $lblanks;
+ my $lvdso_key;
+ my $line_regex;
+
+ my %functions_per_metric_indexes = ();
+ my %functions_per_metric_first_index = ();
+ my @order;
+
+ my ($line,$line_n,$value);
+ my ($df_flag,$n,$u);
+ my ($metric_value,$PC_Address,$routine);
+ my ($is_calls,$metric_ok,$name_regex,$pc_len);
+ my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key);
+
+#------------------------------------------------------------------------------
+# If the directory name does not end with a "/", add it.
+#------------------------------------------------------------------------------
+ my $length_of_string = length ($outputdir);
+
+ if (rindex ($outputdir, "/") != $length_of_string-1)
+ {
+ $outputdir .= "/";
+ }
+
+ gp_message ("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric");
+
+ $is_calls = $FALSE;
+ $metric_ok = $TRUE;
+ $off_with_the_PC = rindex ($FUNC_FILE, "-PC");
+ $FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC);
+
+ if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func")
+ {
+ $FUNC_FILE_NO_PC = $outputdir."calls";
+ $is_calls = $TRUE;
+ $metric_ok = $FALSE;
+ }
+ elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func")
+ {
+ $FUNC_FILE_NO_PC = $outputdir."calltree";
+ $metric_ok = $FALSE;
+ }
+ elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func")
+ {
+ $FUNC_FILE_NO_PC = $outputdir."functions.func";
+ $metric_ok = $FALSE;
+ }
+ gp_message ("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC");
+
+ open (FUNC_FILE, "<", $FUNC_FILE)
+ or die ("Not able to open file $FUNC_FILE for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading");
+
+ open (FUNC_FILE_NO_PC, ">", $FUNC_FILE_NO_PC)
+ or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing");
+
+ open (FUNC_FILE_REGEXP, "<", "$FUNC_FILE.name-regex")
+ or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading");
+
+ $name_regex = <FUNC_FILE_REGEXP>;
+ chomp ($name_regex);
+ close (FUNC_FILE_REGEXP);
+
+ gp_message ("debugXL", $subr_name, "name_regex = $name_regex");
+
+ $n = 0;
+ $u = 0;
+ $pc_len = 0;
+
+#------------------------------------------------------------------------------
+# Note that the double \\ is needed here. The regex used will not have these.
+#------------------------------------------------------------------------------
+ if ($is_calls)
+ {
+#------------------------------------------------------------------------------
+# TBD
+# I do not see the "*" in my test output, but no harm to leave the code in.
+#
+# er_print * before PC for calls ! 101315
+#------------------------------------------------------------------------------
+ $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)";
+ }
+ else
+ {
+ $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)";
+ }
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." line_regex->$line_regex<-");
+ gp_message ("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE");
+
+ $line_n = 0;
+ $index_val = 0;
+ while (<FUNC_FILE>)
+ {
+ $line = $_;
+ chomp ($line);
+
+# gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line");
+
+ $line_n++;
+ if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign
+ {
+#------------------------------------------------------------------------------
+# A typical target line looks like this:
+# 11:0x001492e0 6976.900 <additional_timings> _lwp_start
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "select = $line");
+ if ($is_calls)
+ {
+ $segment = $3;
+ $offset = $5;
+ $spaces = $6;
+ $rest = $7;
+ $PC_Address = $segment.$4.$offset; # PC Addr.
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7");
+ }
+ else
+ {
+ $segment = $2;
+ $offset = $4;
+ $spaces = $5;
+ $rest = $6;
+ $PC_Address = $segment.$3.$offset; # PC Addr.
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5");
+ gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6");
+ }
+ if ($segment == -1)
+ {
+#------------------------------------------------------------------------------
+# presume vDSO field overflow - er_print used an inadequate format
+# or the fsummary (MASTER) had the wrong format for -1?
+# rats - get ahead of ourselves - should not be a field abuttal so
+#------------------------------------------------------------------------------
+ if ($line =~ /$name_regex/)
+ {
+ if ($metric_ok)
+ {
+ $metric_value = $1; # whatever
+ $routine = $2;
+ }
+ else
+ {
+ $routine = $1;
+ }
+ if ($is_calls)
+ {
+ if (substr ($routine,0,1) eq "*")
+ {
+ $routine = substr ($routine,1);
+ }
+ }
+ for $vdso_key (keys %LINUX_vDSO)
+ {
+ if ($routine eq $LINUX_vDSO{$vdso_key})
+ {
+#------------------------------------------------------------------------------
+# presume no duplicates - at least can check offset
+#------------------------------------------------------------------------------
+ if ($vdso_key =~ /(\d+):(\S+)/)
+#------------------------------------------------------------------------------
+# no -ve segments allowed and not expected
+#------------------------------------------------------------------------------
+ {
+ if ($2 eq $offset)
+ {
+#------------------------------------------------------------------------------
+# the real segment
+#------------------------------------------------------------------------------
+ $segment = $1;
+ gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE");
+ $PC_Address = $segment.":".$offset; # PC Addr.
+ gp_message ("debugXL", $subr_name, "vdso line ->$line");
+ $line = $PC_Address.(' ' x (length ($spaces)-2)).$rest;
+ gp_message ("debugXL", $subr_name, "becomes ->$line");
+ last;
+ }
+ }
+ }
+ }
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# a rotten exception for Linux vDSO
+# With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file
+# can have lines like
+#->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<-
+#->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<-
+#->-1:0xff600000 99.040 0 0 [vsyscall]<-
+# (Real PC Address: 4294967295:0xff600000)
+#-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<-
+#-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<-
+# Rats!
+# $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"};
+#------------------------------------------------------------------------------
+
+ $not_printed = $TRUE;
+ for $vdso_key (keys %LINUX_vDSO)
+ {
+ if ($line =~ /^(\s*)($vdso_key)(.*)$/)
+ {
+ $blanks = 1;
+ $rest = 3;
+ $lblanks = length ($blanks);
+ $lvdso_key = length ($vdso_key);
+ $PC_Address = $vdso_key; # PC Addr.
+ $offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key;
+ gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-");
+ if ($pc_len)
+ {
+ print FUNC_FILE_NO_PC substr ($line,$offy)."\n";
+ $not_printed = $FALSE;
+ }
+ else
+ {
+ die ("sod1a");
+ }
+ gp_message ("debugXL", $subr_name, "vdso line ->$line");
+ if (substr ($line,$lblanks+$lvdso_key,1) eq " ")
+ {
+#------------------------------------------------------------------------------
+# O.K. no field abuttal
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line");
+ }
+ else
+ {
+ gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line");
+ $line = $blanks.$vdso_key." ".$rest;
+ }
+ gp_message ("debugXL", $subr_name, "becomes ->$line");
+ last;
+ }
+ }
+ if ($not_printed)
+ {
+ if ($pc_len)
+ {
+ print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
+ }
+ else
+ {
+ die ("sod1b");
+ }
+ $not_printed = $FALSE;
+ }
+ }
+ else
+ {
+ if (!$pc_len)
+ {
+ if ($line =~ /(^\s*PC Addr.\s+)(\S+)/)
+ {
+ $pc_len = length ($1); # say 15
+ print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
+ }
+ else
+ {
+ print FUNC_FILE_NO_PC "$line\n";
+ }
+ }
+ else
+ {
+ if ($pc_len)
+ {
+ my $strlen = length ($line);
+ if ($strlen > 0 )
+ {
+ print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
+ }
+ else
+ {
+ print FUNC_FILE_NO_PC "\n";
+ }
+ }
+ else
+ {
+ die ("sod2");
+ }
+ }
+ next;
+ }
+ $routine = "";
+ if ($line =~ /$name_regex/)
+ {
+ if ($metric_ok)
+ {
+ $metric_value = $1; # whatever
+ $routine = $2;
+ }
+ else
+ {
+ $routine = $1;
+ }
+ }
+
+ if ($is_calls)
+ {
+ if (substr ($routine,0,1) eq "*")
+ {
+ $routine = substr ($routine,1);
+ }
+ }
+ if (length ($routine))
+ {
+ $order[$index_val]{"routine"} = $routine;
+ if ($metric_ok)
+ {
+ $order[$index_val]{"metric_value"} = $metric_value;
+ }
+ $order[$index_val]{"PC Address"} = $PC_Address;
+ $df_flag = 0;
+ if (not exists ($functions_per_metric_indexes{$routine}))
+ {
+ $functions_per_metric_indexes{$routine} = [$index_val];
+ }
+ else
+ {
+ push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list
+ }
+ gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line");
+ if ($PC_Address =~ /\s*(\S+):(\S+)/)
+ {
+ my ($segment,$offset);
+ $segment = $1;
+ $offset = $2;
+ $address_decimal = hex ($offset); # decimal
+ $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280
+ $order[$index_val]{"addressobj"} = $address_decimal;
+ $order[$index_val]{"addressobjtext"} = $full_address_field;
+ }
+#------------------------------------------------------------------------------
+# Check uniqueness
+#------------------------------------------------------------------------------
+ if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address}))
+ {
+ $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val;
+ $u++; #$RI
+ }
+ else
+ {
+ if (!($metric eq "calls" || $metric eq "calltree"))
+ {
+ gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address");
+ }
+ }
+
+ $index_val++;
+ gp_message ("debugXL", $subr_name, "updated index_val = $index_val");
+ $n++;
+ next;
+ }
+ else
+ {
+ if ($n && length ($line))
+ {
+ my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ }
+ close (FUNC_FILE);
+ close (FUNC_FILE_NO_PC);
+
+ for my $i (sort keys %functions_per_metric_indexes)
+ {
+ my $values = "";
+ for my $fields (sort keys @{ $functions_per_metric_indexes{$i} })
+ {
+ $values .= "$functions_per_metric_indexes{$i}[$fields] ";
+ }
+ gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values");
+ }
+
+ return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes);
+
+} #-- End of subroutine function_info
+
+#------------------------------------------------------------------------------
+# Generate a html header.
+#------------------------------------------------------------------------------
+sub generate_a_header
+{
+ my $subr_name = get_my_name ();
+
+ my ($page_text_ref, $size_text_ref, $position_text_ref) = @_;
+
+ my $page_text = ${ $page_text_ref };
+ my $size_text = ${ $size_text_ref };
+ my $position_text = ${ $position_text_ref };
+ my $html_header;
+
+ $html_header = "<div class=\"" . $position_text . "\">\n";
+ $html_header .= "<". $size_text . ">\n";
+ $html_header .= $page_text . "\n";
+ $html_header .= "</". $size_text . ">\n";
+ $html_header .= "</div>";
+
+ gp_message ("debugXL", $subr_name, "on exit page_title = $html_header");
+
+ return (\$html_header);
+
+} #-- End of subroutine generate_a_header
+
+#------------------------------------------------------------------------------
+# Generate the caller-callee information.
+#------------------------------------------------------------------------------
+sub generate_caller_callee
+{
+ my $subr_name = get_my_name ();
+
+ my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref,
+ $function_address_info_ref, $addressobjtextm_ref,
+ $input_string_ref) = @_;
+
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_view_structure = %{ $function_view_structure_ref };
+ my %function_address_info = %{ $function_address_info_ref };
+ my %addressobjtextm = %{ $addressobjtextm_ref };
+ my $input_string = ${ $input_string_ref };
+
+ my @caller_callee_data = ();
+ my $outfile;
+ my $input_line;
+
+ my $fullname;
+ my $separator = "cuthere";
+
+ my @address_field = ();
+ my @fields = ();
+ my @function_names = ();
+ my @marker = ();
+ my @metric_values = ();
+ my @word_index_values = ();
+ my @header_lines = ();
+
+ my $all_metrics;
+ my $elements_in_name;
+ my $full_hex_address;
+ my $hex_address;
+
+ my $file_title;
+ my $page_title;
+ my $size_text;
+ my $position_text;
+ my @html_metric_sort_header = ();
+ my $html_header;
+ my $html_title_header;
+ my $html_home;
+ my $html_acknowledgement;
+ my $html_end;
+ my $html_line;
+
+ my $marker_target_function;
+ my $max_metrics_length = 0;
+ my $metrics_length;
+ my $modified_line;
+ my $name_regex;
+ my $no_of_fields;
+ my $routine;
+ my $routine_length;
+ my $string_length;
+ my $top_header;
+ my $total_header_lines;
+ my $word_index_values_ref;
+ my $infile;
+
+ my $outputdir = append_forward_slash ($input_string);
+ my $LANG = $g_locale_settings{"LANG"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator");
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+
+ $infile = $outputdir . "caller-callee-PC2";
+ $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html";
+
+ gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile");
+
+ open (CALLER_CALLEE_IN, "<", $infile)
+ or die ("unable to open caller file $infile for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened file $infile for reading");
+
+ open (CALLER_CALLEE_OUT, ">", $outfile)
+ or die ("unable to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ gp_message ("debug", $subr_name, "building caller-callee file $outfile");
+
+#------------------------------------------------------------------------------
+# Generate some of the structures used in the HTML output.
+#------------------------------------------------------------------------------
+ $file_title = "Caller-callee overview";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home = ${ generate_home_link ("right") };
+
+ $page_title = "Caller Callee View";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+#------------------------------------------------------------------------------
+# Read all of the file into array with the name caller_callee_data.
+#------------------------------------------------------------------------------
+ chomp (@caller_callee_data = <CALLER_CALLEE_IN>);
+
+#------------------------------------------------------------------------------
+# Typical structure of the input file:
+#
+# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Functions sorted by metric: Exclusive Total CPU Time
+# Callers and callees sorted by metric: Attributed Total CPU Time
+#
+# PC Addr. Name Attr. Attr. CPU Attr. Attr.
+# Total Cycles Instructions Last-Level
+# CPU sec. sec. Executed Cache Misses
+# 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250
+# 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045
+# 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205
+#
+# PC Addr. Name Attr. Attr. CPU Attr. Attr.
+# Total Cycles Instructions Last-Level
+# CPU sec. sec. Executed Cache Misses
+# 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045
+# 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Scan the input file. The first lines are assumed to be part of the header,
+# so we store those. The diagnostic lines that echo some settings are also
+# stored, but currently not used.
+#------------------------------------------------------------------------------
+ my $scan_header = $FALSE;
+ my $scan_caller_callee_data = $FALSE;
+ my $data_function_block = "";
+ my @function_blocks = ();
+ my $first = $TRUE;
+ my @html_caller_callee = ();
+ my @top_level_header = ();
+
+#------------------------------------------------------------------------------
+# The regexes.
+#------------------------------------------------------------------------------
+ my $empty_line_regex = '^\s*$';
+ my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)';
+ my $get_hex_address_regex = '(\d+):0x(\S+)';
+ my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)';
+ my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
+ my $sorted_by_regex = 'sorted by metric:';
+ my $current_regex = '^Current';
+ my $get_addr_offset_regex = '^@\d+:';
+
+#------------------------------------------------------------------------------
+# Get the length of the first metric field across all lines. This value is
+# used to pad the first metric with spaces and get the alignment right.
+#
+# Scan the input data and find the line(s) with metric values. A complication
+# is that a function name may consists of more than one field.
+#
+# Note. This part could be used to parse the other elements of the input file,
+# but that makes the loop very complicated. Instead, we re-scan the data
+# below and process each block separately.
+#
+# Since this data is all in memory and relatively small, the performance should
+# not suffer much, but it does improve the readability of the code.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "determine the maximum length of the first field");
+
+ $g_max_length_first_metric = 0;
+ my @hex_addresses = ();
+ my @special_marker = ();
+ my @the_function_name = ();
+ my @the_metrics = ();
+ my @length_first_metric = ();
+
+ for (my $line = 0; $line <= $#caller_callee_data; $line++)
+ {
+ my $input_line = $caller_callee_data[$line];
+
+ if ($input_line =~ /$line_of_interest_regex/)
+ {
+ if (defined ($1) and defined ($2) and defined ($3))
+#------------------------------------------------------------------------------
+# This is a line of interest, since it has the address, the function name and
+# the values for the metrics. Examples of valid lines are:
+#
+# 2:0x00005028 *xfree_large 0. 0
+# 12:0x0004c2b0 munmap 0.143 6402086
+# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0
+#
+# The function name marked with a * is the current target.
+#------------------------------------------------------------------------------
+ {
+ my $full_hex_address = $1;
+ my $marker = $2;
+ my $remaining_line = $3;
+
+ if ($full_hex_address =~ /$get_hex_address_regex/)
+ {
+ $hex_address = "0x" . $2;
+ push (@hex_addresses, $hex_address);
+ gp_message ("debugXL", $subr_name, "pushed $hex_address");
+ }
+ else
+ {
+ my $msg = "full_hex_address = $full_hex_address has an unknown format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ if ($marker eq "*")
+ {
+ push (@special_marker, "*");
+ }
+ else
+ {
+ push (@special_marker, "X");
+ }
+ }
+ else
+ {
+ my $msg = "input_line = $input_line has an unknown format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ my @fields_in_line = split (" ", $input_line);
+
+#------------------------------------------------------------------------------
+# We stripped the address and marker (if any), off, so this string starts with
+# the function name.
+#------------------------------------------------------------------------------
+ my $remainder = $3;
+ my $number_of_fields = scalar (@fields_in_line);
+ my $words_in_function_name = $number_of_fields - $number_of_metrics - 1;
+ my @remainder_array = split (" ", $remainder);
+
+#------------------------------------------------------------------------------
+# If the first metric is 0. (or 0, depending on the locale), the calculation
+# of the length needs to be adjusted, because 0. is really 0.000.
+#
+# While we could easily add 3 to the length, we assign a symbolic value to the
+# first metric (ZZZ) and then compute the length. This makes things clearer.
+# I hope ;-)
+#------------------------------------------------------------------------------
+ my $first_metric = $remainder_array[$words_in_function_name];
+ if ($first_metric =~ /^0$decimal_separator$/)
+ {
+ gp_message ("debugXL", $subr_name, "fixed up $first_metric");
+ $first_metric = "0.ZZZ";
+ }
+ push (@length_first_metric, length ($first_metric));
+
+ my $txt = "words in function name = $words_in_function_name ";
+ $txt .= "first_metric = $first_metric length = ";
+ $txt .= length ($first_metric);
+ gp_message ("debugXL", $subr_name, $txt);
+
+#------------------------------------------------------------------------------
+# Generate the regex for the metrics.
+#
+# TBD: This should be an attribute of the function and be done once only.
+#------------------------------------------------------------------------------
+ my $m_regex = '(\S+';
+ for my $f (2 .. $words_in_function_name)
+ {
+ $m_regex .= '\s+\S+';
+ }
+#------------------------------------------------------------------------------
+# This last part captures all the metric values.
+#------------------------------------------------------------------------------
+ $m_regex .= $get_metric_field_regex;
+ gp_message ("debugXL", $subr_name, "m_regex = $m_regex");
+ gp_message ("debugXL", $subr_name, "remainder = $remainder");
+
+ if ($remainder =~ /$m_regex/)
+ {
+ my $func_name = $1;
+ my $its_metrics = $2;
+ my $msg = "found the info - func_name = " . $func_name .
+ " its metrics = " . $its_metrics;
+ gp_message ("debugXL", $subr_name, $msg);
+
+ push (@the_function_name, $func_name);
+ push (@the_metrics, $its_metrics);
+ }
+ else
+ {
+ my $msg = "remainder string $remainder has an unrecognized format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ $g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric));
+
+ my $msg = "first_metric = $first_metric " .
+ "g_max_length_first_metric = $g_max_length_first_metric";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+ }
+ gp_message ("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric");
+ gp_message ("debugXL", $subr_name, "#hex_addresses = $#hex_addresses");
+
+#------------------------------------------------------------------------------
+# Main loop over the input data.
+#------------------------------------------------------------------------------
+ my $index_start = 0; # 1
+ my $index_end = -1; # 0
+ for (my $line = 0; $line <= $#caller_callee_data; $line++)
+ {
+ my $input_line = $caller_callee_data[$line];
+
+ if ($input_line =~ /$header_name_regex/)
+ {
+ $scan_header = $TRUE;
+ gp_message ("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first");
+ }
+ elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/))
+ {
+ my $msg = "line = " . $line . " captured top level header: " .
+ "input_line = " . $input_line;
+ gp_message ("debugXL", $subr_name, $msg);
+
+ push (@top_level_header, $input_line);
+ }
+ elsif ($input_line =~ /$line_of_interest_regex/)
+ {
+ $index_end++;
+ $scan_header = $FALSE;
+ $scan_caller_callee_data = $TRUE;
+ $data_function_block .= $separator . $input_line;
+
+ my $msg = "line = $line updated index_end = $index_end";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+ elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data))
+ {
+#------------------------------------------------------------------------------
+# An empty line is interpreted as the end of the current block and we process
+# this, including the generation of the html code for this block.
+#------------------------------------------------------------------------------
+ $first = $FALSE;
+ $scan_caller_callee_data = $FALSE;
+
+ gp_message ("debugXL", $subr_name, "new block");
+ gp_message ("debugXL", $subr_name, "line = $line index_start = $index_start");
+ gp_message ("debugXL", $subr_name, "line = $line index_end = $index_end");
+ gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block");
+
+ push (@function_blocks, $data_function_block);
+ my ($html_block_prologue_ref, $html_code_function_block_ref) =
+ generate_html_function_blocks (
+ \$index_start,
+ \$index_end,
+ \@hex_addresses,
+ \@the_metrics,
+ \@length_first_metric,
+ \@special_marker,
+ \@the_function_name,
+ \$separator,
+ $number_of_metrics_ref,
+ \$data_function_block,
+ $function_info_ref,
+ $function_view_structure_ref);
+
+ my @html_block_prologue = @{ $html_block_prologue_ref };
+ my @html_code_function_block = @{ $html_code_function_block_ref };
+
+ for my $lines (0 .. $#html_code_function_block)
+ {
+ my $msg = "final html_code_function_block[" . $lines . "] = " .
+ $html_code_function_block[$lines];
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+ $data_function_block = "";
+
+ push (@html_caller_callee, @html_block_prologue);
+ push (@html_caller_callee, @header_lines);
+ push (@html_caller_callee, @html_code_function_block);
+
+ $index_start = $index_end + 1;
+ $index_end = $index_start - 1;
+ gp_message ("debugXL", $subr_name, "line = $line reset index_start = $index_start");
+ gp_message ("debugXL", $subr_name, "line = $line reset index_end = $index_end");
+ }
+
+#------------------------------------------------------------------------------
+# Only capture the first header. They are all identical.
+#------------------------------------------------------------------------------
+ if ($scan_header and $first)
+ {
+ if (defined ($4))
+ {
+#------------------------------------------------------------------------------
+# This group is only defined for the first line of the header.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "header1 = $4");
+ gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x");
+ my $newline = "<b>" . $4 . "</b>";
+ push (@header_lines, $newline);
+ }
+ elsif ($input_line =~ /\s*(.*)/)
+ {
+#------------------------------------------------------------------------------
+# Capture the subsequent header lines.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "headern = $1");
+ my $newline = "<b>" . $1 . "</b>";
+ push (@header_lines, $newline);
+ }
+ }
+
+ }
+
+ for my $i (0 .. $#header_lines)
+ {
+ gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
+ }
+ for my $i (0 .. $#function_blocks)
+ {
+ gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]");
+ }
+
+ my $number_of_blocks = $#function_blocks + 1;
+ gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:");
+
+ for my $i (0 .. $#function_blocks)
+ {
+#------------------------------------------------------------------------------
+# The split produces an empty first field and is why we skip the first field.
+#------------------------------------------------------------------------------
+## my @entries = split ("cuthere", $function_blocks[$i]);
+ my @entries = split ($separator, $function_blocks[$i]);
+ for my $k (1 .. $#entries)
+ {
+ my $msg = "entries[" . $k . "] = ". $entries[$k];
+ gp_message ("debugXL", $subr_name, $k . $msg);
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Parse and process the individual function blocks.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#function_blocks)
+ {
+ my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i];
+ gp_message ("debugXL", $subr_name, $msg);
+#------------------------------------------------------------------------------
+# This split produces an empty first field. This is why skip this.
+#------------------------------------------------------------------------------
+ my @entries = split ($separator, $function_blocks[$i]);
+
+#------------------------------------------------------------------------------
+# An example of @entries:
+# <empty>
+# 6:0x0003ad20 drand48 0.100 0.084 768240570 0
+# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
+# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
+#------------------------------------------------------------------------------
+ for my $k (1 .. $#entries)
+ {
+ my $input_line = $entries[$k];
+
+ my $msg = "input_line = entries[" . $k . "] = ". $entries[$k];
+ gp_message ("debugXL", $subr_name, $msg);
+
+ @fields = split (" ", $input_line);
+
+ $no_of_fields = $#fields + 1;
+ $elements_in_name = $no_of_fields - $number_of_metrics - 1;
+
+#------------------------------------------------------------------------------
+# TBD: Too restrictive.
+# CHECK CODE IN GENERATE_CALLER_CALLEE
+#------------------------------------------------------------------------------
+ if ($elements_in_name == 1)
+ {
+ $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)';
+ }
+ elsif ($elements_in_name == 2)
+ {
+ $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)';
+ }
+ else
+#------------------------------------------------------------------------------
+# TBD: Handle this better in case a function entry has more than 2 words.
+#------------------------------------------------------------------------------
+ {
+ my $msg = "$elements_in_name elements in name exceeds limit";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ if ($input_line =~ /$name_regex/)
+ {
+ $full_hex_address = $1;
+ $marker_target_function = $2;
+ $routine = $3;
+ if ($elements_in_name == 1)
+ {
+ $all_metrics = $4;
+ }
+ elsif ($elements_in_name == 2)
+ {
+ $all_metrics = $6;
+ }
+
+ $metrics_length = length ($all_metrics);
+ $max_metrics_length = max ($max_metrics_length, $metrics_length);
+
+ if ($full_hex_address =~ /(\d+):0x(\S+)/)
+ {
+ $hex_address = "0x" . $2;
+ }
+ push (@marker, $marker_target_function);
+ push (@address_field, $hex_address);
+ $modified_line = $all_metrics . " " . $routine;
+ push (@metric_values, $all_metrics);
+ gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line");
+ push (@function_names, $routine);
+ }
+ }
+
+ $total_header_lines = $#header_lines + 1;
+ gp_message ("debugXL", $subr_name, "total_header_lines = $total_header_lines");
+
+ gp_message ("debugXL", $subr_name, "Final output");
+ for my $i (keys @header_lines)
+ {
+ gp_message ("debugXL", $subr_name, "$header_lines[$i]");
+ }
+ for my $i (0 .. $#function_names)
+ {
+ my $msg = $metric_values[$i] . " " . $marker[$i] .
+ $function_names[$i] . "(" . $address_field[$i] . ")";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+#------------------------------------------------------------------------------
+# Check if this function has multiple occurrences.
+# TBD: Replace by the function call for this.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "check for multiple occurrences");
+ for my $i (0 .. $#function_names)
+ {
+ my $current_address = $address_field[$i];
+ my $found_a_match;
+ my $ref_index;
+ my $alt_name;
+ $routine = $function_names[$i];
+ $alt_name = $routine;
+ gp_message ("debugXL", $subr_name, "checking for routine = $routine");
+ if (exists ($g_multi_count_function{$routine}))
+ {
+
+#------------------------------------------------------------------------------
+# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
+#------------------------------------------------------------------------------
+
+ $found_a_match = $FALSE;
+ gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
+ for my $ref (keys @{ $g_map_function_to_index{$routine} })
+ {
+ $ref_index = $g_map_function_to_index{$routine}[$ref];
+
+ gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
+ gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
+
+ my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
+ gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
+
+ $addr_offset =~ s/$get_addr_offset_regex//;
+ gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
+ if ($addr_offset eq $current_address)
+ {
+ $found_a_match = $TRUE;
+ last;
+ }
+ }
+ gp_message ("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match");
+ $alt_name = $function_info[$ref_index]{'alt_name'};
+ }
+ gp_message ("debugXL", $subr_name, "alt_name = $alt_name");
+ }
+ gp_message ("debugXL", $subr_name, "completed check for multiple occurrences");
+
+#------------------------------------------------------------------------------
+# Figure out the column width. Since the columns in the header may include
+# spaces, we use the first line with metrics for this.
+#------------------------------------------------------------------------------
+ my $top_header = $metric_values[0];
+ my $word_index_values_ref = find_words_in_line (\$top_header);
+ my @word_index_values = @{ $word_index_values_ref };
+
+# $i = 0 0 4
+# $i = 1 10 14
+# $i = 2 21 31
+# $i = 3 35 42
+ for my $i (keys @word_index_values)
+ {
+ gp_message ("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]");
+ }
+ }
+
+ push (@html_metric_sort_header, "<i>");
+ for my $i (0 .. $#top_level_header)
+ {
+ $html_line = $top_level_header[$i] . "<br>";
+ push (@html_metric_sort_header, $html_line);
+ }
+ push (@html_metric_sort_header, "</i>");
+
+ print CALLER_CALLEE_OUT $html_header;
+ print CALLER_CALLEE_OUT $html_home;
+ print CALLER_CALLEE_OUT $html_title_header;
+ print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats;
+## print CALLER_CALLEE_OUT "<br>\n";
+## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header;
+ print CALLER_CALLEE_OUT "<pre>\n";
+ print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee;
+ print CALLER_CALLEE_OUT "</pre>\n";
+
+#-------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#-------------------------------------------------------------------------------
+ $html_home = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
+ print CALLER_CALLEE_OUT $html_home;
+ print CALLER_CALLEE_OUT "<br>\n";
+ print CALLER_CALLEE_OUT $html_acknowledgement;
+ print CALLER_CALLEE_OUT $html_end;
+
+ close (CALLER_CALLEE_OUT);
+
+ return (0);
+
+} #-- End of subroutine generate_caller_callee
+
+#------------------------------------------------------------------------------
+# Generate the html version of the disassembly file.
+#
+# Note to self (TBD)
+# https://software.intel.com/content/www/us/en/develop/blogs/intel-release-new-technology-specifications-protect-rop-attacks.html
+#------------------------------------------------------------------------------
+sub generate_dis_html
+{
+ my $subr_name = get_my_name ();
+
+ my ($target_function_ref, $number_of_metrics_ref, $function_info_ref,
+ $function_address_and_index_ref, $outputdir_ref, $func_ref,
+ $source_line_ref, $metric_ref, $addressobj_index_ref) = @_;
+
+ my $target_function = ${ $target_function_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_address_and_index = %{ $function_address_and_index_ref };
+ my $outputdir = ${ $outputdir_ref };
+ my $func = ${ $func_ref };
+ my @source_line = @{ $source_line_ref };
+ my @metric = @{ $metric_ref };
+ my %addressobj_index = %{ $addressobj_index_ref };
+
+ my $dec_instruction_start;
+ my $dec_instruction_end;
+ my $hex_instruction_start;
+ my $hex_instruction_end;
+
+ my @colour_line = ();
+ my $hot_line;
+ my $metric_values;
+ my $src_line;
+ my $dec_instr_address;
+ my $instruction;
+ my $operands;
+
+ my $html_new_line = "<br>";
+ my $add_new_line_before;
+ my $add_new_line_after;
+ my $address_key;
+ my $boldface;
+ my $file;
+ my $filename = $func;
+ my $func_name;
+ my $orig_hex_instr_address;
+ my $hex_instr_address;
+ my $index_string;
+ my $input_metric;
+ my $linenumber;
+ my $name;
+ my $last_address;
+ my $last_address_in_hex;
+
+ my $file_title;
+ my $html_header;
+ my $html_home;
+ my $html_end;
+
+ my $branch_regex = $g_arch_specific_settings{"regex"};
+ my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+ my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
+ my $linksubexp = $g_arch_specific_settings{"linksubexp"};
+ my $subexp = $g_arch_specific_settings{"subexp"};
+
+ my $is_empty;
+
+ my %branch_target = ();
+ my %branch_target_no_ref = ();
+ my @disassembly_file = ();
+ my %extended_branch_target = ();
+ my %inverse_branch_target = ();
+ my @metrics = ();
+ my @modified_html = ();
+
+ my $branch_target_ref;
+ my $extended_branch_target_ref;
+ my $branch_target_no_ref_ref;
+
+ my $branch_address;
+ my $dec_branch_address;
+ my $found_it;
+ my $found_it_ref;
+ my $func_name_in_dis_file;
+ my $hex_branch_target;
+ my $instruction_address;
+ my $instruction_offset;
+ my $link;
+ my $modified_line;
+ my $raw_hex_branch_target;
+ my $src_line_ref;
+ my $threshold_line;
+ my $html_dis_out = $func . ".html";
+
+#------------------------------------------------------------------------------
+# The regex section.
+#------------------------------------------------------------------------------
+ my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)';
+ my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]';
+ my $white_space_regex = '\s+';
+ my $first_integer_regex = '^\d+$';
+ my $integer_regex = '\d+';
+ my $qmark_regex = '\?';
+ my $src_regex = '(\s*)(\d+)\.(.*)';
+ my $function_regex = '^(\s*)<Function:\s(.*)>';
+ my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)";
+ my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>";
+ my $control_flow_1_regex = 'j[a-z]+';
+ my $control_flow_2_regex = 'call';
+ my $control_flow_3_regex = 'ret';
+
+## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
+## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
+#------------------------------------------------------------------------------
+# Dynamic. Computed below.
+#
+# TBD: Try to move these up.
+#------------------------------------------------------------------------------
+ my $dis_regex;
+ my $metric_regex;
+
+ gp_message ("debug", $subr_name, "g_branch_regex = $g_branch_regex");
+ gp_message ("debug", $subr_name, "call_regex = $call_regex");
+ gp_message ("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex");
+
+ my $the_title = set_title ($function_info_ref, $func, "disassembly");
+
+ gp_message ("debug", $subr_name, "the_title = $the_title");
+
+ $file_title = $the_title;
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home = ${ generate_home_link ("right") };
+
+ push (@modified_html, $html_header);
+ push (@modified_html, $html_home);
+ push (@modified_html, "<pre>");
+
+#------------------------------------------------------------------------------
+# Open the input and output files.
+#------------------------------------------------------------------------------
+ open (INPUT_DISASSEMBLY, "<", $filename)
+ or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
+ gp_message ("debug", $subr_name , "opened file $filename for reading");
+
+ open (HTML_OUTPUT, ">", $html_dis_out)
+ or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'");
+ gp_message ("debug", $subr_name , "opened file $html_dis_out for writing");
+
+#------------------------------------------------------------------------------
+# Check if the file is empty
+#------------------------------------------------------------------------------
+ $is_empty = is_file_empty ($filename);
+ if ($is_empty)
+ {
+
+#------------------------------------------------------------------------------
+# The input file is empty. Write a message in the html file and exit.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name ,"file $filename is empty");
+
+ my $comment = "No disassembly generated by $tool_name - file $filename is empty";
+ my $gp_error_file = $outputdir . "gp-listings.err";
+
+ my $html_empty_file_ref = html_text_empty_file (\$comment, \$gp_error_file);
+ my @html_empty_file = @{ $html_empty_file_ref };
+
+ print HTML_OUTPUT "$_\n" for @html_empty_file;
+
+ close (HTML_OUTPUT);
+
+ return (\@source_line);
+ }
+ else
+ {
+
+#------------------------------------------------------------------------------
+# Read the file into memory.
+#------------------------------------------------------------------------------
+ chomp (@disassembly_file = <INPUT_DISASSEMBLY>);
+ gp_message ("debug", $subr_name ,"read file $filename into memory");
+ }
+
+ my $max_length_first_metric = 0;
+ my $src_line_no;
+
+#------------------------------------------------------------------------------
+# First scan through the assembly listing.
+#------------------------------------------------------------------------------
+ for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
+ {
+ my $input_line = $disassembly_file[$line_no];
+ gp_message ("debugXL", $subr_name, "[line $line_no] $input_line");
+
+ if ($input_line =~ /$line_of_interest_regex/)
+ {
+
+#------------------------------------------------------------------------------
+# Found a matching line. Examples are:
+# 0.370 [37] 4021d1: addsd %xmm0,%xmm1
+# ## 1.001 [36] 4021d5: add $0x1,%rax
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2");
+
+ if (defined ($2) and defined($1))
+ {
+ @metrics = split (/$white_space_regex/ ,$1);
+ $src_line_no = $2;
+ }
+ else
+ {
+ my $msg = "$input_line has an unexpected format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Compute the maximum length of the first metric and pad the field from the
+# left later on. The fractional part is ignored.
+#------------------------------------------------------------------------------
+ my $first_metric = $metrics[0];
+ my $new_length;
+ if ($first_metric =~ /$first_integer_regex/)
+ {
+ $new_length = length ($first_metric);
+ }
+ else
+ {
+ my @fields = split (/$decimal_separator/, $first_metric);
+ $new_length = length ($fields[0]);
+ }
+ $max_length_first_metric = max ($max_length_first_metric, $new_length);
+ my $msg;
+ $msg = "first_metric = $first_metric " .
+ "max_length_first_metric = $max_length_first_metric";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ if ($src_line_no !~ /$qmark_regex/)
+#------------------------------------------------------------------------------
+# The source code line number is known and is stored.
+#------------------------------------------------------------------------------
+ {
+ $source_line[$line_no] = $src_line_no;
+ my $msg;
+ $msg = "found an instruction with a source line ref: ";
+ $msg .= "source_line[$line_no] = $source_line[$line_no]";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Check for function calls. If found, get the address offset from $4 and
+# compute the target address.
+#------------------------------------------------------------------------------
+ ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) =
+ check_and_proc_dis_func_call (
+ \$input_line,
+ \$line_no,
+ \%branch_target,
+ \%extended_branch_target);
+ $found_it = ${ $found_it_ref };
+
+ if ($found_it)
+ {
+ %branch_target = %{ $branch_target_ref };
+ %extended_branch_target = %{ $extended_branch_target_ref };
+ }
+
+#------------------------------------------------------------------------------
+# 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.
+#------------------------------------------------------------------------------
+ ($found_it_ref, $branch_target_ref, $extended_branch_target_ref,
+ $branch_target_no_ref_ref) = check_and_proc_dis_branches (
+ \$input_line,
+ \$line_no,
+ \%branch_target,
+ \%extended_branch_target,
+ \%branch_target_no_ref);
+ $found_it = ${ $found_it_ref };
+
+ if ($found_it)
+ {
+ %branch_target = %{ $branch_target_ref };
+ %extended_branch_target = %{ $extended_branch_target_ref };
+ %branch_target_no_ref = %{ $branch_target_no_ref_ref };
+ }
+ }
+ } #-- End of loop over line_no
+
+ %inverse_branch_target = reverse (%extended_branch_target);
+
+ gp_message ("debug", $subr_name, "generated inverse of branch target structure");
+ gp_message ("debug", $subr_name, "completed parsing file $filename");
+
+ for my $key (sort keys %branch_target)
+ {
+ gp_message ("debug", $subr_name, "branch_target{$key} = $branch_target{$key}");
+ }
+ for my $key (sort keys %extended_branch_target)
+ {
+ gp_message ("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}");
+ }
+ for my $key (sort keys %inverse_branch_target)
+ {
+ gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
+ }
+ for my $key (sort keys %branch_target_no_ref)
+ {
+ gp_message ("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}");
+ $inverse_branch_target{$key} = $key;
+ }
+ for my $key (sort keys %inverse_branch_target)
+ {
+ gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
+ }
+
+#------------------------------------------------------------------------------
+# Process the disassembly.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Dynamically generate the regexes.
+#------------------------------------------------------------------------------
+ $metric_regex = '';
+ for my $metric_used (1 .. $number_of_metrics)
+ {
+ $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
+ }
+
+ $dis_regex = '^(#{2}|\s{2})\s+';
+ $dis_regex .= '(.*)';
+ $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)';
+
+ gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex");
+ gp_message ("debugXL", $subr_name, "dis_regex = $dis_regex");
+ gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
+ gp_message ("debugXL", $subr_name, "contents of lines array");
+
+#------------------------------------------------------------------------------
+# Identify the header lines. Make the minimal assumptions.
+#
+# In both cases, the first line after the header has whitespace. This is
+# followed by:
+#
+# - A source line file has "<line_no>."
+# - A dissasembly file has "<Function:"
+#
+# These are the characteristics we use below.
+#------------------------------------------------------------------------------
+ for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
+ {
+ my $input_line = $disassembly_file[$line_no];
+ gp_message ("debugXL", $subr_name, "[line $line_no] $input_line");
+
+ if ($input_line =~ /$end_src_header_regex/)
+ {
+ gp_message ("debugXL", $subr_name, "header time is over - hit source line\n");
+ gp_message ("debugXL", $subr_name, "$1 $2 $3\n");
+ last;
+ }
+ if ($input_line =~ /$end_dis_header_regex/)
+ {
+ gp_message ("debugXL", $subr_name, "header time is over - hit disassembly line\n");
+ last;
+ }
+ push (@modified_html, "<i>" . $input_line . "</i>");
+
+ }
+ my $line_index = scalar (@modified_html);
+ gp_message ("debugXL", $subr_name, "final line_index = $line_index");
+
+ for (my $line_no=0; $line_no <= $line_index-1; $line_no++)
+ {
+ my $msg = " modified_html[$line_no] = $modified_html[$line_no]";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Source line:
+# 20. for (int64_t r=0; r<repeat_count; r++) {
+#
+# Disassembly:
+# 0.340 [37] 401fec: addsd %xmm0,%xmm1
+# ## 1.311 [36] 401ff0: addq $1,%rax
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Find the hot PCs and store them.
+#------------------------------------------------------------------------------
+ my @hot_program_counters = ();
+ my @transposed_hot_pc = ();
+ my @max_metric_values = ();
+
+ gp_message ("debug", $subr_name, "determine the maximum metric values");
+ for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
+ {
+ my $input_line = $disassembly_file[$line_no];
+
+ if ( $input_line =~ /$dis_regex/ )
+ {
+ if ( defined ($1) and defined ($2) and defined ($3) and
+ defined ($4) and defined ($5) and defined ($6) )
+ {
+ $hot_line = $1;
+ $metric_values = $2;
+ $src_line = $3;
+ $dec_instr_address = hex ($4);
+ $instruction = $5;
+ $operands = $6;
+
+ if ($hot_line eq "##")
+ {
+ my @metrics = split (" ", $metric_values);
+ push (@hot_program_counters, [@metrics]);
+ }
+ }
+ }
+ }
+ for my $row (keys @hot_program_counters)
+ {
+ my $msg = "$filename row[" . $row . "] = ";
+ for my $col (keys @{$hot_program_counters[$row]})
+ {
+ $msg .= "$hot_program_counters[$row][$col] ";
+ $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col];
+ }
+ gp_message ("debugXL", $subr_name, "hot PC = $msg");
+ }
+ for my $row (keys @transposed_hot_pc)
+ {
+ my $msg = "$filename row[" . $row . "] = ";
+ for my $col (keys @{$transposed_hot_pc[$row]})
+ {
+ $msg .= "$transposed_hot_pc[$row][$col] ";
+ }
+ gp_message ("debugXL", $subr_name, "$filename transposed = $msg");
+ }
+#------------------------------------------------------------------------------
+# Get the maximum metric values and if integer, convert to floating-point.
+# Since it is easier, we transpose the array and access it over the columns.
+#------------------------------------------------------------------------------
+ for my $row (0 .. $#transposed_hot_pc)
+ {
+ my $max_val = 0;
+ for my $col (0 .. $#{$transposed_hot_pc[$row]})
+ {
+ $max_val = max ($transposed_hot_pc[$row][$col], $max_val);;
+ }
+ if ($max_val =~ /$integer_regex/)
+ {
+ $max_val = sprintf ("%f", $max_val);
+ }
+ gp_message ("debugXL", $subr_name, "$filename row = $row max_val = $max_val");
+ push (@max_metric_values, $max_val);
+ }
+
+ for my $metric (0 .. $#max_metric_values)
+ {
+ my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]";
+ gp_message ("debugM", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# TBD - Integrate this better.
+#
+# Scan the instructions to find the instruction address range. This is used
+# to determine if a branch is external to this function.
+#------------------------------------------------------------------------------
+ $dec_instruction_start = undef;
+ $dec_instruction_end = undef;
+ for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
+ {
+ my $input_line = $disassembly_file[$line_no];
+ if ( $input_line =~ /$dis_regex/ )
+ {
+ if ( defined ($1) and defined ($2) and defined ($3) and
+ defined ($4) and defined ($5) and defined ($6) )
+ {
+ $hot_line = $1;
+ $metric_values = $2;
+ $src_line = $3;
+ $dec_instr_address = hex ($4);
+ $instruction = $5;
+ $operands = $6;
+
+ if (defined ($dec_instruction_start))
+ {
+ if ($dec_instr_address < $dec_instruction_start)
+ {
+ $dec_instruction_start = $dec_instr_address;
+ }
+ }
+ else
+ {
+ $dec_instruction_start = $dec_instr_address;
+ }
+ if (defined ($dec_instruction_end))
+ {
+ if ($dec_instr_address > $dec_instruction_end)
+ {
+ $dec_instruction_end = $dec_instr_address;
+ }
+ }
+ else
+ {
+ $dec_instruction_end = $dec_instr_address;
+ }
+ }
+ }
+ }
+
+ if (defined ($dec_instruction_start) and defined ($dec_instruction_end))
+ {
+ $hex_instruction_start = sprintf ("%x", $dec_instruction_start);
+ $hex_instruction_end = sprintf ("%x", $dec_instruction_end);
+
+ my $msg;
+ $msg = "$filename $func dec_instruction_start = " .
+ "$dec_instruction_start (0x$hex_instruction_start)";
+ gp_message ("debugXL", $subr_name, $msg);
+ $msg = "$filename $func dec_instruction_end = " .
+ "$dec_instruction_end (0x$hex_instruction_end)";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# This is where all the results from above come together.
+#------------------------------------------------------------------------------
+ for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
+ {
+ my $input_line = $disassembly_file[$line_no];
+ gp_message ("debugXL", $subr_name, "input_line[$line_no] = $input_line");
+ if ( $input_line =~ /$dis_regex/ )
+ {
+ gp_message ("debugXL", $subr_name, "found a disassembly line: $input_line");
+ if ( defined ($1) and defined ($2) and defined ($3) and
+ defined ($4) and defined ($5) and defined ($6) )
+ {
+# $branch_target{$hex_branch_target} = 1;
+# $extended_branch_target{$instruction_address} = $raw_hex_branch_target;
+ $hot_line = $1;
+ $metric_values = $2;
+ $src_line = $3;
+ $orig_hex_instr_address = $4;
+ $instruction = $5;
+ $operands = $6;
+
+ gp_message ("debugXL", $subr_name, "disassembly line: $1 $2 $3 $4 $5 \$6 = $6");
+
+#------------------------------------------------------------------------------
+# Pad the line with the metrics to ensure correct alignment.
+#------------------------------------------------------------------------------
+ my $the_length;
+ my @split_metrics = split (" ", $metric_values);
+ my $first_metric = $split_metrics[0];
+## if ($first_metric =~ /^\d+$/)
+ if ($first_metric =~ /$first_integer_regex/)
+ {
+ $the_length = length ($first_metric);
+ }
+ else
+ {
+ my @fields = split (/$decimal_separator/, $first_metric);
+ $the_length = length ($fields[0]);
+ }
+ my $spaces = $max_length_first_metric - $the_length;
+ my $pad = "";
+ for my $p (1 .. $spaces)
+ {
+ $pad .= " ";
+ }
+ $metric_values = $pad . $metric_values;
+ gp_message ("debugXL", $subr_name, "pad = $pad");
+ gp_message ("debugXL", $subr_name, "metric_values = $metric_values");
+
+#------------------------------------------------------------------------------
+# Since the instruction address variable may change and because we need the
+# original address without html controls, we use a new variable for the
+# (potentially) modified address.
+#------------------------------------------------------------------------------
+ $hex_instr_address = $orig_hex_instr_address;
+ $add_new_line_before = $FALSE;
+ $add_new_line_after = $FALSE;
+
+ if ($src_line eq "?")
+
+#------------------------------------------------------------------------------
+# There is no source line number. Do not add a link.
+#------------------------------------------------------------------------------
+ {
+ $modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] ';
+ gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line");
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# There is a source line number. Mark it as link.
+#------------------------------------------------------------------------------
+ $src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]";
+ gp_message ("debugXL", $subr_name, "src_line_ref = $src_line_ref");
+ gp_message ("debugXL", $subr_name, "hex_instr_address = $hex_instr_address");
+
+ $modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' ';
+ gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line");
+ }
+
+#------------------------------------------------------------------------------
+# Mark control flow instructions. Several cases need to be distinguished.
+#
+# In all cases we give the instruction a specific color, mark it boldface
+# and add a new-line after the instruction
+#------------------------------------------------------------------------------
+ if ( ($instruction =~ /$control_flow_1_regex/) or
+ ($instruction =~ /$control_flow_2_regex/) or
+ ($instruction =~ /$control_flow_3_regex/) )
+ {
+ gp_message ("debugXL", $subr_name, "instruction = $instruction is a control flow instruction");
+
+ $add_new_line_after = $TRUE;
+
+ $boldface = $TRUE;
+ $instruction = color_string ($instruction, $boldface, $g_html_color_scheme{"control_flow"});
+ }
+
+ if (exists ($extended_branch_target{$hex_instr_address}))
+#------------------------------------------------------------------------------
+# This is a branch instruction and we need to add the target address.
+#
+# In case the target address is outside of this load object, the link is
+# colored differently.
+#
+# TBD: Add the name and if possible, a working link to this code.
+#------------------------------------------------------------------------------
+ {
+ $branch_address = $extended_branch_target{$hex_instr_address};
+
+ $dec_branch_address = hex ($branch_address);
+
+ if ( ($dec_branch_address >= $dec_instruction_start) and
+ ($dec_branch_address <= $dec_instruction_end) )
+#------------------------------------------------------------------------------
+# The instruction is within the range.
+#------------------------------------------------------------------------------
+ {
+ $link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]";
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# The instruction is outside of the range. Change the color of the link.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "address is outside of range");
+
+ $link = "[ <a href='#".$branch_address;
+ $link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>";
+ $link .= $branch_address."</a> ]";
+ }
+ gp_message ("debugXL", $subr_name, "address exists new link = $link");
+
+ $operands .= ' ' . $link;
+ gp_message ("debugXL", $subr_name, "update #1 modified_line = $modified_line");
+ }
+ if (exists ($branch_target_no_ref{$hex_instr_address}))
+ {
+ gp_message ("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}");
+ }
+## if (exists ($inverse_branch_target{$hex_instr_address}) or
+## exists ($branch_target_no_ref{$hex_instr_address}))
+ if (exists ($inverse_branch_target{$hex_instr_address}))
+#------------------------------------------------------------------------------
+# This is a target address and we need to define the instruction address to be
+# a label.
+#------------------------------------------------------------------------------
+ {
+ $add_new_line_before = $TRUE;
+
+ my $branch_target = $inverse_branch_target{$hex_instr_address};
+ my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:";
+ gp_message ("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address");
+ gp_message ("debugXL", $subr_name, "inverse exists - add a target target = $target");
+
+ $hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>";
+ gp_message ("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address");
+ gp_message ("debugXL", $subr_name, "update #2 modified_line = $modified_line");
+ }
+
+ $modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands;
+
+ gp_message ("debugXL", $subr_name, "final modified_line = $modified_line");
+
+#------------------------------------------------------------------------------
+# This is a control flow instruction, but it is the last one and we do not
+# want to add a newline.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html");
+ gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after");
+ gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before");
+
+ if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) )
+ {
+ $add_new_line_after = $FALSE;
+ gp_message ("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline");
+ }
+
+ if ($add_new_line_before)
+ {
+
+#------------------------------------------------------------------------------
+# Get the previous line, if any, so that we can check what it is.
+#------------------------------------------------------------------------------
+ my $prev_line = pop (@modified_html);
+ if ( defined ($prev_line) )
+ {
+ gp_message ("debugXL", $subr_name, "prev_line = $prev_line");
+
+#------------------------------------------------------------------------------
+# Restore the previously popped line.
+#------------------------------------------------------------------------------
+ push (@modified_html, $prev_line);
+ if ($prev_line ne $html_new_line)
+ {
+ gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line");
+#------------------------------------------------------------------------------
+# There is no new-line yet, so add it.
+#------------------------------------------------------------------------------
+ push (@modified_html, $html_new_line);
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# It was a new-line, so do nothing and continue.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "need to restore $html_new_line");
+ }
+ }
+ }
+#------------------------------------------------------------------------------
+# Add the newly created line.
+#------------------------------------------------------------------------------
+
+ if ($hot_line eq "##")
+#------------------------------------------------------------------------------
+# Highlight the most expensive line.
+#------------------------------------------------------------------------------
+ {
+ $modified_line = set_background_color_string (
+ $modified_line,
+ $g_html_color_scheme{"background_color_hot"});
+ }
+#------------------------------------------------------------------------------
+# Sub-highlight the lines close enough to the hot line.
+#------------------------------------------------------------------------------
+ else
+ {
+ my @current_metrics = split (" ", $metric_values);
+ for my $metric (0 .. $#current_metrics)
+ {
+ my $current_value;
+ my $max_value;
+ $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");
+ my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
+ gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance");
+ if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0))
+ {
+ gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
+ gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line");
+ $modified_line = set_background_color_string (
+ $modified_line,
+ $g_html_color_scheme{"background_color_lukewarm"});
+ last;
+ }
+ }
+ }
+ }
+ }
+
+## my @max_metric_values = ();
+ push (@modified_html, $modified_line);
+ if ($add_new_line_after)
+ {
+ gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line");
+ push (@modified_html, $html_new_line);
+ }
+
+ }
+ else
+ {
+ my $msg = "parsing line $input_line";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ elsif ( $input_line =~ /$src_regex/ )
+ {
+ if ( defined ($1) and defined ($2) )
+ {
+####### BUG?
+ gp_message ("debugXL", $subr_name, "found a source code line: $input_line");
+ gp_message ("debugXL", $subr_name, "\$1 = $1");
+ gp_message ("debugXL", $subr_name, "\$2 = $2");
+ gp_message ("debugXL", $subr_name, "\$3 = $3");
+ my $blanks = $1;
+ my $src_line = $2;
+ my $src_code = $3;
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+ my $target = "<a name='line_".$src_line."'>".$src_line.".</a>";
+ gp_message ("debugXL", $subr_name, "src target = $target $src_code");
+
+ my $modified_line = $blanks . $target . $src_code;
+ gp_message ("debugXL", $subr_name, "modified_line = $modified_line");
+ push (@modified_html, $modified_line);
+ }
+ else
+ {
+ my $msg = "parsing line $input_line";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ elsif ( $input_line =~ /$function_regex/ )
+ {
+ my $html_name;
+ if (defined ($1) and defined ($2))
+ {
+ $func_name_in_dis_file = $2;
+ my $spaces = $1;
+ my $boldface = $TRUE;
+ gp_message ("debugXL", $subr_name, "function_name = $2");
+ my $function_line = "<Function: " . $func_name_in_dis_file . ">";
+
+##### HACK
+
+ if ($func_name_in_dis_file eq $target_function)
+ {
+ my $color_function_name = color_string (
+ $function_line,
+ $boldface,
+ $g_html_color_scheme{"target_function_name"});
+ my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>";
+ $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>";
+ }
+ else
+ {
+ my $color_function_name = color_string (
+ $function_line,
+ $boldface,
+ $g_html_color_scheme{"non_target_function_name"});
+ $html_name = "<i>" . $spaces . $color_function_name . "</i>";
+ }
+ push (@modified_html, $html_name);
+ }
+ else
+ {
+ my $msg = "parsing line $input_line";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Add an extra line with diagnostics.
+#
+# TBD: The same is done in process_source but should be done only once.
+#------------------------------------------------------------------------------
+ if ($hp_value > 0)
+ {
+ my $rounded_percentage = sprintf ("%.1f", $hp_value);
+ $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
+ }
+ else
+ {
+ $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
+ }
+
+ $html_home = ${ generate_home_link ("left") };
+ $html_end = ${ terminate_html_document () };
+
+ push (@modified_html, "</pre>");
+ push (@modified_html, $html_new_line);
+ push (@modified_html, $threshold_line);
+ push (@modified_html, $html_home);
+ push (@modified_html, $html_new_line);
+ push (@modified_html, $g_html_credits_line);
+ push (@modified_html, $html_end);
+
+ for my $i (0 .. $#modified_html)
+ {
+ gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
+ }
+
+ for my $i (0 .. $#modified_html)
+ {
+ print HTML_OUTPUT "$modified_html[$i]" . "\n";
+ }
+
+ close (HTML_OUTPUT);
+ close (INPUT_DISASSEMBLY);
+
+ gp_message ("debug", $subr_name, "output is in file $html_dis_out");
+ gp_message ("debug", $subr_name ,"completed processing disassembly");
+
+ undef %branch_target;
+ undef %extended_branch_target;
+ undef %inverse_branch_target;
+
+ return (\@source_line, \@metric);
+
+} #-- End of subroutine generate_dis_html
+
+#------------------------------------------------------------------------------
+# Generate all the function level information.
+#------------------------------------------------------------------------------
+sub generate_function_level_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string,
+ $sort_fields_ref) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+ my @sort_fields = @{ $sort_fields_ref };
+
+ my $expr_name;
+ my $first_metric;
+ my $gp_display_text_cmd;
+ my $gp_functions_cmd;
+ my $ignore_value;
+ my $script_pc_metrics;
+
+ my $outputdir = append_forward_slash ($input_string);
+
+ my $script_file_PC = $outputdir."gp-script-PC";
+ my $result_file = $outputdir."gp-out-PC.err";
+ my $gp_error_file = $outputdir."gp-out-PC.err";
+ my $func_limit = $g_user_settings{func_limit}{current_value};
+
+#------------------------------------------------------------------------------
+# The number of entries in the Function Overview includes <Total>, but that is
+# not a concern to the user and we add "1" to compensate for this.
+#------------------------------------------------------------------------------
+ $func_limit += 1;
+
+ gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit");
+
+ $expr_name = join (" ", @exp_dir_list);
+
+ gp_message ("debug", $subr_name, "expr_name = $expr_name");
+
+ for my $i (0 .. $#sort_fields)
+ {
+ gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]");
+ }
+
+# Ruud $count = 0;
+
+ gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files");
+
+ open (SCRIPT_PC, ">", $script_file_PC)
+ or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened file $script_file_PC for writing");
+
+#------------------------------------------------------------------------------
+# Get the list of functions.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Get the first metric.
+#------------------------------------------------------------------------------
+ $summary_metrics =~ /^([^:]+)/;
+ $first_metric = $1;
+ $g_first_metric = $1;
+ $script_pc_metrics = "address:$summary_metrics";
+
+ gp_message ("debugXL", $subr_name, "$func_limit");
+ gp_message ("debugXL", $subr_name, "$summary_metrics");
+ gp_message ("debugXL", $subr_name, "$first_metric");
+ gp_message ("debugXL", $subr_name, "$script_pc_metrics");
+
+# Temporarily disabled print SCRIPT_PC "# limit $func_limit\n";
+# Temporarily disabled print SCRIPT_PC "limit $func_limit\n";
+ print SCRIPT_PC "# thread_select all\n";
+ print SCRIPT_PC "thread_select all\n";
+
+#------------------------------------------------------------------------------
+# Empty header.
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."header\n";
+ print SCRIPT_PC "outfile $outputdir"."header\n";
+
+#------------------------------------------------------------------------------
+# Else the output from the next line goes to last sort.func
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n";
+ print SCRIPT_PC "# metrics $script_pc_metrics\n";
+ print SCRIPT_PC "metrics $script_pc_metrics\n";
+#------------------------------------------------------------------------------
+# Not really sorted
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n";
+ print SCRIPT_PC "# functions\n";
+ print SCRIPT_PC "functions\n";
+
+ print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n";
+ print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n";
+ print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "# sort $first_metric\n";
+ print SCRIPT_PC "sort $first_metric\n";
+ print SCRIPT_PC "# functions\n";
+ print SCRIPT_PC "functions\n";
+#------------------------------------------------------------------------------
+# Go through all the possible metrics and sort by each of them.
+#------------------------------------------------------------------------------
+ for my $field (@sort_fields)
+ {
+ gp_message ("debug", $subr_name, "sort_fields field = $field");
+#------------------------------------------------------------------------------
+# Else the output from the next line goes to last sort.func
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n";
+ print SCRIPT_PC "# metrics $script_pc_metrics\n";
+ print SCRIPT_PC "metrics $script_pc_metrics\n";
+ print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n";
+ print SCRIPT_PC "# sort $field\n";
+ print SCRIPT_PC "sort $field\n";
+ print SCRIPT_PC "# functions\n";
+ print SCRIPT_PC "functions\n";
+
+ print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n";
+ print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n";
+ print SCRIPT_PC "# sort $field\n";
+ print SCRIPT_PC "sort $field\n";
+ print SCRIPT_PC "# functions\n";
+ print SCRIPT_PC "functions\n";
+ }
+
+#------------------------------------------------------------------------------
+# Get caller-callee list
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n";
+ print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n";
+ print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "metrics address:name:$summary_metrics\n";
+ print SCRIPT_PC "# callers-callees\n";
+ print SCRIPT_PC "callers-callees\n";
+#------------------------------------------------------------------------------
+# Else the output from the next line goes to last sort.func
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n";
+ $script_pc_metrics = "address:$call_metrics";
+ print SCRIPT_PC "# metrics $script_pc_metrics\n";
+ print SCRIPT_PC "metrics $script_pc_metrics\n";
+
+#------------------------------------------------------------------------------
+# Not really sorted
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n";
+
+#------------------------------------------------------------------------------
+# Get caller-callee list
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# callers-callees\n";
+ print SCRIPT_PC "callers-callees\n";
+
+#------------------------------------------------------------------------------
+# Else the output from the next line goes to last sort.func
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n";
+ print SCRIPT_PC "# metrics $script_pc_metrics\n";
+ print SCRIPT_PC "metrics $script_pc_metrics\n";
+
+ if ($g_user_settings{"calltree"}{"current_value"} eq "on")
+ {
+ gp_message ("verbose", $subr_name, "Generate the file with the calltree information");
+#------------------------------------------------------------------------------
+# Get calltree list
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n";
+ print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n";
+ print SCRIPT_PC "# calltree\n";
+ print SCRIPT_PC "calltree\n";
+ }
+
+#------------------------------------------------------------------------------
+# Get the default set of metrics
+#------------------------------------------------------------------------------
+ my $full_metrics_ref;
+ my $all_metrics;
+ my $full_function_view = $outputdir . "functions.full";
+
+ $full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir);
+
+ $all_metrics = "address:name:";
+ $all_metrics .= ${$full_metrics_ref};
+ gp_message ("debug", $subr_name, "all_metrics = $all_metrics");
+#------------------------------------------------------------------------------
+# Get the name, address, and full overview of all metrics for all functions
+#------------------------------------------------------------------------------
+ print SCRIPT_PC "# limit 0\n";
+ print SCRIPT_PC "limit 0\n";
+ print SCRIPT_PC "# metrics $all_metrics\n";
+ print SCRIPT_PC "metrics $all_metrics\n";
+ print SCRIPT_PC "# thread_select all\n";
+ print SCRIPT_PC "thread_select all\n";
+ print SCRIPT_PC "# sort default\n";
+ print SCRIPT_PC "sort default\n";
+ print SCRIPT_PC "# outfile $full_function_view\n";
+ print SCRIPT_PC "outfile $full_function_view\n";
+ print SCRIPT_PC "# functions\n";
+ print SCRIPT_PC "functions\n";
+
+ close (SCRIPT_PC);
+
+ $result_file = $outputdir."gp-out-PC.err";
+ $gp_error_file = $outputdir.$g_gp_error_logfile;
+
+ $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit ";
+ $gp_functions_cmd .= "-viewmode machine -compare off ";
+ $gp_functions_cmd .= "-script $script_file_PC $expr_name";
+
+ gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information");
+
+ $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
+
+ gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd");
+
+ my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", "execution terminated");
+ }
+
+#-------------------------------------------------------------------------------
+# Parse the full function view and store the data.
+#-------------------------------------------------------------------------------
+ my @input_data = ();
+ my $empty_line_regex = '^\s*$';
+
+## my $full_function_view = $outputdir . "functions.full";
+
+ open (ALL_FUNC_DATA, "<", $full_function_view)
+ or die ("$subr_name - unable to open output file $full_function_view for reading '$!'");
+ gp_message ("debug", $subr_name, "opened file $full_function_view for reading");
+
+ chomp (@input_data = <ALL_FUNC_DATA>);
+
+ my $start_scanning = $FALSE;
+ for (my $line = 0; $line <= $#input_data; $line++)
+ {
+ my $input_line = $input_data[$line];
+
+# if ($input_line =~ /^<Total>\s+.*/)
+ if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/)
+ {
+ $start_scanning = $TRUE;
+ }
+ elsif ($input_line =~ /$empty_line_regex/)
+ {
+ $start_scanning = $FALSE;
+ }
+
+ if ($start_scanning)
+ {
+ gp_message ("debugXL", $subr_name, "$line: $input_data[$line]");
+
+ push (@g_full_function_view_table, $input_data[$line]);
+
+ my $hex_address;
+ my $full_hex_address = $1;
+ my $routine = $2;
+ my $all_metrics = $3;
+ if ($full_hex_address =~ /(\d+):0x(\S+)/)
+ {
+ $hex_address = "0x" . $2;
+ }
+ $g_function_view_all{$routine}{"hex_address"} = $hex_address;
+ $g_function_view_all{$routine}{"all_metrics"} = $all_metrics;
+ }
+ }
+
+ for my $i (keys %g_function_view_all)
+ {
+ gp_message ("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}");
+ }
+
+ for my $i (keys @g_full_function_view_table)
+ {
+ gp_message ("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]");
+ }
+
+ return ($script_pc_metrics);
+
+} #-- End of subroutine generate_function_level_info
+
+#------------------------------------------------------------------------------
+# Generate all the files needed for the function view.
+#------------------------------------------------------------------------------
+sub generate_function_view
+{
+ my $subr_name = get_my_name ();
+
+ my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref,
+ $function_info_ref, $function_view_structure_ref, $function_address_info_ref,
+ $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_;
+
+ my $directory_name = ${ $directory_name_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_view_structure = %{ $function_view_structure_ref };
+ my $summary_metrics = ${ $summary_metrics_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my %function_address_info = %{ $function_address_info_ref };
+ my @sort_fields = @{ $sort_fields_ref };
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+ my %addressobjtextm = %{ $addressobjtextm_ref };
+
+ my @abs_path_exp_dirs = ();
+ my @experiment_directories;
+
+ my $target_function;
+ my $html_line;
+ my $ftag;
+ my $routine_length;
+ my %html_source_functions = ();
+
+ my $href_link;
+ my $infile;
+ my $input_experiments;
+ my $keep_value;
+ my $loadobj;
+ my $address_field;
+ my $address_offset;
+ my $msg;
+ my $exe;
+ my $extra_field;
+ my $new_target_function;
+ my $file_title;
+ my $html_output_file;
+ my $html_function_view;
+ my $overview_file;
+ my $exp_name;
+ my $exp_type;
+ my $html_header;
+ my $routine;
+ my $length_header;
+ my $length_metrics;
+ my $full_index_line;
+ my $acknowledgement;
+ my @full_function_view_line = ();
+ my $spaces;
+ my $size_text;
+ my $position_text;
+ my $html_first_metric_file;
+ my $html_new_line = "<br>";
+ my $html_acknowledgement;
+ my $html_end;
+ my $html_home;
+ my $page_title;
+ my $html_title_header;
+
+ my $outputdir = append_forward_slash ($directory_name);
+ my $LANG = $g_locale_settings{"LANG"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ $input_experiments = join (", ", @exp_dir_list);
+
+ for my $i (0 .. $#exp_dir_list)
+ {
+ my $dir = get_basename ($exp_dir_list[$i]);
+ push @abs_path_exp_dirs, $dir;
+ }
+ $input_experiments = join (", ", @abs_path_exp_dirs);
+
+ gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
+
+#------------------------------------------------------------------------------
+# TBD: This should be done only once and much earlier.
+#------------------------------------------------------------------------------
+ @experiment_directories = split (",", $input_experiments);
+
+#------------------------------------------------------------------------------
+# For every function in the function overview, set up an html structure with
+# the various hyperlinks.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Core loop that generates an HTML line for each function.
+#------------------------------------------------------------------------------
+ my $top_of_table = $FALSE;
+ for my $i (0 .. $#function_info)
+ {
+ if (defined ($function_info[$i]{"alt_name"}))
+ {
+ $target_function = $function_info[$i]{"alt_name"};
+ }
+ else
+ {
+ my $msg = "function_info[$i]{\"alt_name\"} is not defined";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ $html_source_functions{$target_function} = $function_info[$i]{"html function block"};
+ }
+
+ for my $i (sort keys %html_source_functions)
+ {
+ gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
+ }
+
+ $file_title = "Function view for experiments " . $input_experiments;
+
+#------------------------------------------------------------------------------
+# Example input file:
+
+# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Functions sorted by metric: Exclusive Total CPU Time
+#
+# PC Addr. Name Excl. Excl. CPU Excl. Excl.
+# Total Cycles Instructions Last-Level
+# CPU sec. sec. Executed Cache Misses
+# 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250
+# 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045
+# 6:0x0003af50 erand48_r 0.080 0.084 768240570 0
+# 2:0x00001f7b init_data 0.040 0.028 64020043 200205
+# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
+# ...
+#------------------------------------------------------------------------------
+
+ for my $metric (@sort_fields)
+ {
+ $overview_file = $outputdir . $metric . ".sort.func-PC2";
+
+ $exp_type = $metric;
+
+ if ($metric eq "functions")
+ {
+ $html_function_view .= $g_html_base_file_name{"function_view"} . ".html";
+ }
+ else
+ {
+ $html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html";
+ }
+#------------------------------------------------------------------------------
+# The default function view is based upon the first metric in the list. We use
+# this file in the index.html file.
+#------------------------------------------------------------------------------
+ if ($metric eq $g_first_metric)
+ {
+ $html_first_metric_file = $html_function_view;
+ my $txt = "g_first_metric = $g_first_metric ";
+ $txt .= "html_first_metric_file = $html_first_metric_file";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+
+ $html_output_file = $outputdir . $html_function_view;
+
+ open (FUNCTION_VIEW, ">", $html_output_file)
+ or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
+
+ $html_home = ${ generate_home_link ("right") };
+ $html_header = ${ create_html_header (\$file_title) };
+
+ $page_title = "Function View";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+ print FUNCTION_VIEW $html_header;
+ print FUNCTION_VIEW $html_home;
+ print FUNCTION_VIEW $html_title_header;
+ print FUNCTION_VIEW "$_" for @g_html_experiment_stats;
+ print FUNCTION_VIEW $html_new_line . "\n";
+
+ my $function_view_structure_ref = process_function_overview (
+ \$metric,
+ \$exp_type,
+ \$summary_metrics,
+ \$number_of_metrics,
+ \@function_info,
+ \%function_view_structure,
+ \$overview_file);
+
+ my %function_view_structure = %{ $function_view_structure_ref };
+
+#------------------------------------------------------------------------------
+# Core part: extract the true function name and find the html code for it.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "the final table");
+
+ print FUNCTION_VIEW "<pre>\n";
+ print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} };
+
+ my $max_length_header = $function_view_structure{"max header length"};
+ my $max_length_metrics = $function_view_structure{"max metrics length"};
+
+#------------------------------------------------------------------------------
+# Add 4 more spaces for the distance to the function names. Purely cosmetic.
+#------------------------------------------------------------------------------
+ my $pad = max ($max_length_metrics, $max_length_header) + 4;
+ my $spaces = "";
+ for my $i (1 .. $pad)
+ {
+ $spaces .= " ";
+ }
+
+#------------------------------------------------------------------------------
+# Add extra space for the /blank/*/ marker!
+#------------------------------------------------------------------------------
+ $spaces .= " ";
+ my $func_header = $spaces . $function_view_structure{"table name"};
+ gp_message ("debugXL", $subr_name, "func_header = " . $func_header);
+
+
+ print FUNCTION_VIEW $spaces . "<b>" .
+ $function_view_structure{"table name"} .
+ "</b>" . $html_new_line . "\n";
+
+#------------------------------------------------------------------------------
+# If the header is longer than the metrics, add spaces to padd the difference.
+# Also add the same 4 spaces between the metric values and the function name.
+#------------------------------------------------------------------------------
+ $pad = 0;
+ if ($max_length_header > $max_length_metrics)
+ {
+ $pad = $max_length_header - $max_length_metrics;
+ }
+ $pad += 4;
+ $spaces = "";
+ for my $i (1 .. $pad)
+ {
+ $spaces .= " ";
+ }
+
+#------------------------------------------------------------------------------
+# This is where it literally all comes together. The metrics and function
+# parts are combined.
+#------------------------------------------------------------------------------
+## for my $i (keys @{ $function_view_structure{"function table"} })
+ for my $i (0 .. $#{ $function_view_structure{"function table"} })
+ {
+ my $p1 = $function_view_structure{"metrics part"}[$i];
+ my $p2 = $function_view_structure{"function table"}[$i];
+
+ $full_index_line = $p1 . $spaces . $p2;
+
+ push (@full_function_view_line, $full_index_line);
+ }
+
+ print FUNCTION_VIEW "$_\n" for @full_function_view_line;
+
+#-------------------------------------------------------------------------------
+# Clear the array before filling it up again.
+#-------------------------------------------------------------------------------
+ @full_function_view_line = ();
+
+#-------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#-------------------------------------------------------------------------------
+ $html_home = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
+ print FUNCTION_VIEW "</pre>\n";
+ print FUNCTION_VIEW $html_home;
+ print FUNCTION_VIEW $html_new_line . "\n";
+ print FUNCTION_VIEW $html_acknowledgement;
+ print FUNCTION_VIEW $html_end;
+
+ close (FUNCTION_VIEW);
+ }
+
+ return (\$html_first_metric_file);
+
+} #-- End of subroutine generate_function_view
+
+#------------------------------------------------------------------------------
+# Generate an html line that links back to index.html. The text can either
+# be positioned to the left or to the right.
+#------------------------------------------------------------------------------
+sub generate_home_link
+{
+ my $subr_name = get_my_name ();
+
+ my ($which_side) = @_;
+
+ my $html_home_line;
+
+ if (($which_side ne "left") and ($which_side ne "right"))
+ {
+ my $msg = "which_side = $which_side not supported";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ $html_home_line .= "<div class=\"" . $which_side . "\">";
+ $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"};
+ $html_home_line .= ".html' style='background-color:";
+ $html_home_line .= $g_html_color_scheme{"index"};
+ $html_home_line .= "'><b>Return to main view</b></a>";
+ $html_home_line .= "</div>";
+
+ return (\$html_home_line);
+
+} #-- End of subroutine generate_home_link
+
+#------------------------------------------------------------------------------
+# Generate a block of html for this function block.
+#------------------------------------------------------------------------------
+sub generate_html_function_blocks
+{
+ my $subr_name = get_my_name ();
+
+ my (
+ $index_start_ref,
+ $index_end_ref,
+ $hex_addresses_ref,
+ $the_metrics_ref,
+ $length_first_metric_ref,
+ $special_marker_ref,
+ $the_function_name_ref,
+ $separator_ref,
+ $number_of_metrics_ref,
+ $data_function_block_ref,
+ $function_info_ref,
+ $function_view_structure_ref) = @_;
+
+ my $index_start = ${ $index_start_ref };
+ my $index_end = ${ $index_end_ref };
+ my @hex_addresses = @{ $hex_addresses_ref };
+ my @the_metrics = @{ $the_metrics_ref };
+ my @length_first_metric = @{ $length_first_metric_ref };
+ my @special_marker = @{ $special_marker_ref };
+ my @the_function_name = @{ $the_function_name_ref};
+
+ my $separator = ${ $separator_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my $data_function_block = ${ $data_function_block_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_view_structure = %{ $function_view_structure_ref };
+
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ my @html_block_prologue = ();
+ my @html_code_function_block = ();
+ my @function_lines = ();
+ my @fields = ();
+ my @address_field = ();
+ my @metric_values = ();
+ my @function_names = ();
+ my @final_function_names = ();
+ my @marker = ();
+ my @split_number = ();
+ my @function_tags = ();
+
+ my $all_metrics;
+ my $current_function_name;
+ my $no_of_fields;
+ my $name_regex;
+ my $full_hex_address;
+ my $hex_address;
+ my $target_function;
+ my $marker_function;
+ my $routine;
+ my $routine_length;
+ my $metrics_length;
+ my $max_metrics_length = 0;
+ my $modified_line;
+ my $string_length;
+ my $addr_offset;
+ my $current_address;
+ my $found_a_match;
+ my $ref_index;
+ my $alt_name;
+ my $length_first_field;
+ my $gap;
+ my $ipad;
+ my $html_line;
+ my $target_tag;
+ my $tag_for_header;
+ my $href_file;
+ my $found_alt_name;
+ my $name_in_header;
+ my $create_hyperlinks;
+
+ state $first_call = $TRUE;
+ state $reference_length;
+
+#------------------------------------------------------------------------------
+# If the length of the first metric is less than the maximum over all first
+# metrics, add spaces to the left to ensure correct alignment.
+#------------------------------------------------------------------------------
+ for my $k ($index_start .. $index_end)
+ {
+ my $pad = $g_max_length_first_metric - $length_first_metric[$k];
+ if ($pad ge 1)
+ {
+ my $spaces = "";
+ for my $s (1 .. $pad)
+ {
+ $spaces .= " ";
+ }
+ $the_metrics[$k] = $spaces . $the_metrics[$k];
+
+ my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k];
+## gp_message ("debugXL", $subr_name, $end_game);
+ }
+
+#------------------------------------------------------------------------------
+# An example what @function_lines should look like after the split:
+# <empty>
+# 6:0x0003ad20 drand48 0.100 0.084 768240570 0
+# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
+# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
+#------------------------------------------------------------------------------
+ @function_lines = split ($separator, $data_function_block);
+
+#------------------------------------------------------------------------------
+# Parse the individual lines. Replace multi-occurrence functions by their
+# unique alternative name and mark the target function.
+#
+# The above split operation produces an empty first field because the line
+# starts with the separator. This is why skip the first field.
+#------------------------------------------------------------------------------
+ for my $i ($index_start .. $index_end)
+ {
+ my $input_line = $the_metrics[$i];
+
+ gp_message ("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]);
+
+#------------------------------------------------------------------------------
+# In case the last metric is 0. only, we append 3 extra characters that
+# represent zero. We cannot change the number to 0.000 though because that
+# has a different interpretation than 0.
+# In a later phase, the "ZZZ" symbol will be removed again, but for now it
+# creates consistency in, for example, the length of the metrics part.
+#------------------------------------------------------------------------------
+ if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/)
+ {
+ if (defined ($1) )
+ {
+ my $decimal_point = $decimal_separator;
+ $decimal_point =~ s/\\//;
+ my $txt = "input_line = $input_line = ended with 0";
+ $txt .= $decimal_point;
+ gp_message ("debugXL", $subr_name, $txt);
+
+ $the_metrics[$i] .= "ZZZ";
+ }
+ }
+
+ $hex_address = $hex_addresses[$i];
+ $marker_function = $special_marker[$i];
+ $routine = $the_function_name[$i];
+#------------------------------------------------------------------------------
+# Get the length of the metrics line before ZZZ is replaced by spaces.
+#------------------------------------------------------------------------------
+ $all_metrics = $the_metrics[$i];
+ $metrics_length = length ($all_metrics);
+ $all_metrics =~ s/ZZZ/ /g;
+
+ $max_metrics_length = max ($max_metrics_length, $metrics_length);
+
+ push (@marker, $marker_function);
+ push (@address_field, $hex_address);
+ push (@metric_values, $all_metrics);
+ push (@function_names, $routine);
+
+ my $index_into_function_info_ref = get_index_function_info (
+ \$routine,
+ \$hex_addresses[$i],
+ $function_info_ref);
+
+ my $index_into_function_info = ${ $index_into_function_info_ref };
+ $target_tag = $function_info[$index_into_function_info]{"tag_id"};
+ $alt_name = $function_info[$index_into_function_info]{"alt_name"};
+
+#------------------------------------------------------------------------------
+# Keep the name of the target function (the one marked with a *) for later use.
+# This is the tag that identifies the block in the caller-callee output. The
+# tag is used in the link to the caller-callee in the function overview.
+#------------------------------------------------------------------------------
+ if ($marker_function eq "*")
+ {
+ $tag_for_header = $target_tag;
+ $name_in_header = $alt_name;
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+ }
+ push (@final_function_names, $alt_name);
+ push (@function_tags, $target_tag);
+
+ gp_message ("debugXL", $subr_name, "index_into_function_info = $index_into_function_info");
+ gp_message ("debugXL", $subr_name, "target_tag = $target_tag");
+ gp_message ("debugXL", $subr_name, "alt_name = $alt_name");
+
+ } #-- End of loop for my $i ($index_start .. $index_end)
+
+ my $tag_line = "<a id='" . $tag_for_header . "'></a>";
+ $html_line = "<br>\n";
+ $html_line .= $tag_line . "Function name: ";
+ $html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>";
+ $html_line .= "<b>" . $name_in_header . "</b></span>\n";
+ $html_line .= "<br>";
+
+ push (@html_block_prologue, $html_line);
+
+ gp_message ("debugXL", $subr_name, "the final function block for $name_in_header");
+
+ $href_file = $g_html_base_file_name{"caller_callee"} . ".html";
+
+#------------------------------------------------------------------------------
+# Process the function blocks and generate the HTML structure for them.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#final_function_names)
+ {
+ $current_function_name = $final_function_names[$i];
+ gp_message ("debugXL", $subr_name, "current_function_name = $current_function_name");
+
+#------------------------------------------------------------------------------
+# Do not add hyperlinks for <Total>.
+#------------------------------------------------------------------------------
+ if ($current_function_name eq "<Total>")
+ {
+ $create_hyperlinks = $FALSE;
+ }
+ else
+ {
+ $create_hyperlinks = $TRUE;
+ }
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+ $html_line = $metric_values[$i] . " ";
+
+ if ($marker[$i] eq "*")
+ {
+ $current_function_name = "<b>" . $current_function_name . "</b>";
+ }
+ $html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>";
+
+ if ($marker[$i] eq "*")
+ {
+ $html_line = "<br>" . $html_line;
+ }
+ elsif (($marker[$i] ne "*") and ($i == 0))
+ {
+ $html_line = "<br>" . $html_line;
+ }
+
+ gp_message ("debugXL", $subr_name, "html_line = $html_line");
+
+#------------------------------------------------------------------------------
+# Find the index into "function_info" for this particular function.
+#------------------------------------------------------------------------------
+ $routine = $function_names[$i];
+ $current_address = $address_field[$i];
+
+ my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info);
+ my $target_index = ${ $target_index_ref };
+
+ gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index");
+
+#------------------------------------------------------------------------------
+# TBD Do this once for each function and store the result. This is a saving
+# because functions may and typically will appear more than once.
+#------------------------------------------------------------------------------
+ my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"};
+
+#------------------------------------------------------------------------------
+# Add the links to the line. Make sure there is at least one space.
+#------------------------------------------------------------------------------
+ my $spaces = " ";
+ for my $k (1 .. $spaces_left)
+ {
+ $spaces .= " ";
+ }
+
+ if ($create_hyperlinks)
+ {
+ $html_line .= $spaces;
+ $html_line .= $function_info[$target_index]{"href_source"};
+ $html_line .= " ";
+ $html_line .= $function_info[$target_index]{"href_disassembly"};
+ }
+
+ push (@html_code_function_block, $html_line);
+ }
+
+ for my $lines (0 .. $#html_code_function_block)
+ {
+ gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]);
+ }
+
+ return (\@html_block_prologue, \@html_code_function_block);
+
+} #-- End of subroutine generate_html_function_blocks
+
+#------------------------------------------------------------------------------
+# Generate the index.html file.
+#------------------------------------------------------------------------------
+sub generate_index
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref,
+ $number_of_metrics_ref, $function_info_ref, $function_address_info_ref,
+ $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref,
+ $metric_description_reversed_ref, $number_of_warnings_ref,
+ $table_execution_stats_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+ my $html_first_metric_file = ${ $html_first_metric_file_ref };
+ my $summary_metrics = ${ $summary_metrics_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_address_info = %{ $function_address_info_ref };
+ my @sort_fields = @{ $sort_fields_ref };
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+ my %addressobjtextm = %{ $addressobjtextm_ref };
+ my %metric_description_reversed = %{ $metric_description_reversed_ref };
+ my $number_of_warnings = ${ $number_of_warnings_ref };
+ my @table_execution_stats = @{ $table_execution_stats_ref };
+
+ my @file_contents = ();
+
+ my $acknowledgement;
+ my @abs_path_exp_dirs = ();
+ my $input_experiments;
+ my $target_function;
+ my $html_line;
+ my $ftag;
+ my $max_length = 0;
+ my %html_source_functions = ();
+ my $html_header;
+ my @experiment_directories = ();
+ my $html_acknowledgement;
+ my $html_file_title;
+ my $html_output_file;
+ my $html_function_view;
+ my $html_caller_callee_view;
+ my $html_experiment_info;
+ my $html_warnings_page;
+ my $href_link;
+ my $file_title;
+ my $html_gprofng;
+ my $html_end;
+ my $max_length_metrics;
+ my $page_title;
+ my $size_text;
+ my $position_text;
+
+ my $ln;
+ my $base;
+ my $base_index_page;
+ my $infile;
+ my $outfile;
+ my $rec;
+ my $skip;
+ my $callsize;
+ my $dest;
+ my $final_string;
+ my @headers;
+ my $header;
+ my $sort_index;
+ my $pc_address;
+ my $anchor;
+ my $directory_name;
+ my $f2;
+ my $f3;
+ my $file;
+ my $sline;
+ my $src;
+ my $srcfile_name;
+ my $tmp1;
+ my $tmp2;
+ my $fullsize;
+ my $regf2;
+ my $trimsize;
+ my $EIL;
+ my $EEIL;
+ my $AOBJ;
+ my $RI;
+ my $HDR;
+ my $CALLER_CALLEE;
+ my $NAME;
+ my $SRC;
+ my $TRIMMED;
+
+#------------------------------------------------------------------------------
+# Add a forward slash to make it easier when creating file names.
+#------------------------------------------------------------------------------
+ $outputdir = append_forward_slash ($outputdir);
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+
+ my $LANG = $g_locale_settings{"LANG"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ $input_experiments = join (", ", @exp_dir_list);
+
+ for my $i (0 .. $#exp_dir_list)
+ {
+ my $dir = get_basename ($exp_dir_list[$i]);
+ push @abs_path_exp_dirs, $dir;
+ }
+ $input_experiments = join (", ", @abs_path_exp_dirs);
+
+ gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
+
+#------------------------------------------------------------------------------
+# TBD: Pass in the values for $expr_name and $cmd
+#------------------------------------------------------------------------------
+ $html_file_title = "Main index page";
+
+ @experiment_directories = split (",", $input_experiments);
+ $html_acknowledgement = ${ create_html_credits () };
+
+ $html_end = ${ terminate_html_document () };
+
+ $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html";
+
+ open (INDEX, ">", $html_output_file)
+ or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
+
+ $page_title = "GPROFNG Performance Analysis";
+ $size_text = "h1";
+ $position_text = "center";
+ $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+ $html_header = ${ create_html_header (\$html_file_title) };
+
+ print INDEX $html_header;
+ print INDEX $html_gprofng;
+ print INDEX "$_" for @g_html_experiment_stats;
+ print INDEX "$_" for @table_execution_stats;
+
+ $html_experiment_info = "<a href=\'";
+ $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html";
+ $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n";
+
+ $html_warnings_page = "<a href=\'";
+ $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html";
+ $html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n";
+
+ $html_function_view = "<a href=\'";
+ $html_function_view .= $html_first_metric_file;
+ $html_function_view .= "\'><h3>Function View</h3></a>\n";
+
+ $html_caller_callee_view = "<a href=\'";
+ $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html";
+ $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n";
+
+ print INDEX "<br>\n";
+## print INDEX "<b>\n";
+ print INDEX $html_experiment_info;
+ print INDEX $html_warnings_page;;
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
+ print INDEX $html_function_view;
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
+ print INDEX $html_caller_callee_view;
+## print INDEX "</b>\n";
+## print INDEX "<br>\n";
+## print INDEX "<br>\n";
+
+ print INDEX $html_acknowledgement;
+ print INDEX $html_end;
+
+ close (INDEX);
+
+ gp_message ("debug", $subr_name, "closed file $html_output_file");
+
+ return (0);
+
+} #-- End of subroutine generate_index
+
+#------------------------------------------------------------------------------
+# Get all the metrics available
+#
+# (gp-display-text) metric_list
+# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Available metrics:
+# Exclusive Total CPU Time: e.%totalcpu
+# Inclusive Total CPU Time: i.%totalcpu
+# Exclusive CPU Cycles: e.+%cycles
+# Inclusive CPU Cycles: i.+%cycles
+# Exclusive Instructions Executed: e+%insts
+# Inclusive Instructions Executed: i+%insts
+# Exclusive Last-Level Cache Misses: e+%llm
+# Inclusive Last-Level Cache Misses: i+%llm
+# Exclusive Instructions Per Cycle: e+IPC
+# Inclusive Instructions Per Cycle: i+IPC
+# Exclusive Cycles Per Instruction: e+CPI
+# Inclusive Cycles Per Instruction: i+CPI
+# Size: size
+# PC Address: address
+# Name: name
+#------------------------------------------------------------------------------
+sub get_all_the_metrics
+{
+ my $subr_name = get_my_name ();
+
+ my ($experiments_ref, $outputdir_ref) = @_;
+
+ my $experiments = ${ $experiments_ref };
+ my $outputdir = ${ $outputdir_ref };
+
+ my $ignore_value;
+ my $gp_functions_cmd;
+ my $gp_display_text_cmd;
+
+ my $metrics_output_file = $outputdir . "metrics-all";
+ my $result_file = $outputdir . $g_gp_output_file;
+ my $gp_error_file = $outputdir . $g_gp_error_logfile;
+ my $script_file_metrics = $outputdir . "script-metrics";
+
+ my @metrics_data = ();
+
+ open (SCRIPT_METRICS, ">", $script_file_metrics)
+ or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing");
+
+ print SCRIPT_METRICS "# outfile $metrics_output_file\n";
+ print SCRIPT_METRICS "outfile $metrics_output_file\n";
+ print SCRIPT_METRICS "# metric_list\n";
+ print SCRIPT_METRICS "metric_list\n";
+
+ close (SCRIPT_METRICS);
+
+ $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments";
+
+ gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics");
+
+ $gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file";
+ gp_message ("debug", $subr_name, "cmd = $gp_display_text_cmd");
+
+ my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+
+ open (METRICS_INFO, "<", $metrics_output_file)
+ or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'");
+ gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading");
+
+#------------------------------------------------------------------------------
+# Read the input file into memory.
+#------------------------------------------------------------------------------
+ chomp (@metrics_data = <METRICS_INFO>);
+ gp_message ("debug", $subr_name, "read all contents of file $metrics_output_file into memory");
+ gp_message ("debug", $subr_name, "\$#metrics_data = $#metrics_data");
+
+ my $input_line;
+ my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)';
+ my $split_line_regex = '(.*): (.*)';
+ my $empty_line_regex = '^\s*$';
+ my @metric_list_all = ();
+ for (my $line_no=0; $line_no <= $#metrics_data; $line_no++)
+ {
+
+ $input_line = $metrics_data[$line_no];
+
+## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/))))
+ if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) )
+ {
+ if ($input_line =~ /$split_line_regex/)
+ {
+#------------------------------------------------------------------------------
+# Remove the percentages.
+#------------------------------------------------------------------------------
+ my $metric_definition = $2;
+ $metric_definition =~ s/\%//g;
+ gp_message ("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition");
+ push (@metric_list_all, $metric_definition);
+ }
+ }
+
+ }
+
+ gp_message ("debug", $subr_name, "\@metric_list_all = @metric_list_all");
+
+ my $final_list = join (":", @metric_list_all);
+ gp_message ("debug", $subr_name, "final_list = $final_list");
+
+ close (METRICS_INFO);
+
+ return (\$final_list);
+
+} #-- End of subroutine get_all_the_metrics
+
+#------------------------------------------------------------------------------
+# A simple function to return the basename using fileparse. To keep things
+# simple, a suffixlist is not supported. In case this is needed, use the
+# fileparse function directly.
+#------------------------------------------------------------------------------
+sub get_basename
+{
+ my ($full_name) = @_;
+
+ my $ignore_value_1;
+ my $ignore_value_2;
+ my $basename_value;
+
+ ($basename_value, $ignore_value_1, $ignore_value_2) = fileparse ($full_name);
+
+ return ($basename_value);
+
+} #-- End of subroutine get_basename
+
+#------------------------------------------------------------------------------
+# Get the details on the experiments and store these in a file. Each
+# experiment has its own file. This makes the processing easier.
+#------------------------------------------------------------------------------
+sub get_experiment_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref, $exp_dir_list_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my $cmd_output;
+ my $current_slot;
+ my $error_code;
+ my $exp_info_file;
+ my @exp_info = ();
+ my @experiment_data = ();
+ my $gp_error_file;
+ my $gp_display_text_cmd;
+ my $gp_functions_cmd;
+ my $gp_log_file;
+ my $ignore_value;
+ my $overview_file;
+ my $result_file;
+ my $script_file;
+ my $the_experiments;
+
+ $the_experiments = join (" ", @exp_dir_list);
+
+ $script_file = $outputdir . "gp-info-exp.script";
+ $exp_info_file = $outputdir . "gp-info-exp-list.out";
+ $overview_file = $outputdir . "gp-overview.out";
+ $gp_log_file = $outputdir . $g_gp_output_file;
+ $gp_error_file = $outputdir . $g_gp_error_logfile;
+
+ open (SCRIPT_EXPERIMENT_INFO, ">", $script_file)
+ or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened script file $script_file for writing");
+
+#------------------------------------------------------------------------------
+# Attributed User CPU Time=a.user : for calltree - see P37 in manual
+#------------------------------------------------------------------------------
+ print SCRIPT_EXPERIMENT_INFO "# compare on\n";
+ print SCRIPT_EXPERIMENT_INFO "compare on\n";
+ print SCRIPT_EXPERIMENT_INFO "# outfile $exp_info_file\n";
+ print SCRIPT_EXPERIMENT_INFO "outfile $exp_info_file\n";
+ print SCRIPT_EXPERIMENT_INFO "# exp_list\n";
+ print SCRIPT_EXPERIMENT_INFO "exp_list\n";
+ print SCRIPT_EXPERIMENT_INFO "# outfile $overview_file\n";
+ print SCRIPT_EXPERIMENT_INFO "outfile $overview_file\n";
+ print SCRIPT_EXPERIMENT_INFO "# overview\n";
+ print SCRIPT_EXPERIMENT_INFO "overview\n";
+
+ close SCRIPT_EXPERIMENT_INFO;
+
+ $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
+
+ gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information");
+
+ $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
+
+ ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+
+#-------------------------------------------------------------------------------
+# The first file has the following format:
+#
+# ID Sel PID Experiment
+# == === ======= ======================================================
+# 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er
+# 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er
+#-------------------------------------------------------------------------------
+ open (EXP_INFO, "<", $exp_info_file)
+ or die ("$subr_name - unable to open file $exp_info_file for reading '$!'");
+ gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading");
+
+ chomp (@exp_info = <EXP_INFO>);
+
+#-------------------------------------------------------------------------------
+# TBD - Check for the groups to exist below:
+#-------------------------------------------------------------------------------
+ $current_slot = 0;
+ for my $i (0 .. $#exp_info)
+ {
+ my $input_line = $exp_info[$i];
+
+ gp_message ("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]");
+
+ if ($input_line =~ /^\s*(\d+)\s+(.+)/)
+ {
+ my $exp_id = $1;
+ my $remainder = $2;
+ $experiment_data[$current_slot]{"exp_id"} = $exp_id;
+ $experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out";
+ gp_message ("debug", $subr_name, $i . " " . $exp_id . " " . $remainder);
+ if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/)
+ {
+ my $exp_name = $3;
+ $experiment_data[$current_slot]{"exp_name_full"} = $exp_name;
+ $experiment_data[$current_slot]{"exp_name_short"} = get_basename ($exp_name);
+ $current_slot++;
+ gp_message ("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3);
+ }
+ else
+ {
+ my $msg = "remainder = $remainder has an unexpected format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ }
+#-------------------------------------------------------------------------------
+# The experiment IDs and names are known. We can now generate the info for
+# each individual experiment.
+#-------------------------------------------------------------------------------
+ $gp_log_file = $outputdir . $g_gp_output_file;
+ $gp_error_file = $outputdir . $g_gp_error_logfile;
+
+ $script_file = $outputdir . "gp-details-exp.script";
+
+ open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file)
+ or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened script file $script_file for writing");
+
+ for my $i (sort keys @experiment_data)
+ {
+ my $exp_id = $experiment_data[$i]{"exp_id"};
+
+ $result_file = $experiment_data[$i]{"exp_data_file"};
+
+# statistics
+# header
+ print SCRIPT_EXPERIMENT_DETAILS "# outfile " . $result_file . "\n";
+ print SCRIPT_EXPERIMENT_DETAILS "outfile " . $result_file . "\n";
+ print SCRIPT_EXPERIMENT_DETAILS "# header " . $exp_id . "\n";
+ print SCRIPT_EXPERIMENT_DETAILS "header " . $exp_id . "\n";
+ print SCRIPT_EXPERIMENT_DETAILS "# statistics " . $exp_id . "\n";
+ print SCRIPT_EXPERIMENT_DETAILS "statistics " . $exp_id . "\n";
+
+ }
+
+ close (SCRIPT_EXPERIMENT_DETAILS);
+
+ $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
+
+ gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment details");
+
+ $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
+
+ ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+#-------------------------------------------------------------------------------
+# This is unlikely to happen, but you never know.
+#-------------------------------------------------------------------------------
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+
+ return (\@experiment_data);
+
+} #-- End of subroutine get_experiment_info
+
+#------------------------------------------------------------------------------
+# This subroutine returns a string of the type "size=<n>", where <n> is the
+# size of the file passed in. If n > 1024, a unit is appended.
+#------------------------------------------------------------------------------
+sub getfilesize
+{
+ my $subr_name = get_my_name ();
+
+ my ($filename) = @_;
+
+ my $size;
+ my $file_stat;
+
+ if (not -e $filename)
+ {
+#------------------------------------------------------------------------------
+# The return value is used in the caller. This is why we return the empty
+# string in case the file does not exist.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "filename = $filename not found");
+ return ("");
+ }
+ else
+ {
+ $file_stat = stat ($filename);
+ $size = $file_stat->size;
+
+ gp_message ("debug", $subr_name, "filename = $filename");
+ gp_message ("debug", $subr_name, "size = $size");
+
+ if ($size > 1024)
+ {
+ if ($size > 1024*1024)
+ {
+ $size = $size/1024/1024;
+ $size =~ s/\..*//;
+ $size = $size."MB";
+ }
+ else
+ {
+ $size = $size/1024;
+ $size =~ s/\..*//;
+ $size = $size."KB";
+ }
+ }
+ else
+ {
+ $size=$size." bytes";
+ }
+ gp_message ("debug", $subr_name, "size = $size title=\"$size\"");
+
+ return ("title=\"$size\"");
+ }
+
+} #-- End of subroutine getfilesize
+
+#------------------------------------------------------------------------------
+# Parse the fsummary output and for all functions, store all the information
+# found in "function_info". In addition to this, several derived structures
+# are stored as well, making this structure a "onestop" place to get all the
+# info that is needed.
+#------------------------------------------------------------------------------
+sub get_function_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($FSUMMARY_FILE) = @_;
+
+ my @function_info = ();
+ my %functions_address_and_index = ();
+ my %LINUX_vDSO = ();
+ my %function_view_structure = ();
+ my %addressobjtextm = ();
+#------------------------------------------------------------------------------
+# TBD: This structure is no longer used and most likely can be removed.
+#------------------------------------------------------------------------------
+ my %functions_index = ();
+
+# TBD: check
+ my $full_address_field;
+ my %source_files = ();
+
+ my $i;
+ my $line;
+ my $routine_flag;
+ my $value;
+ my $whatever;
+ my $df_flag;
+ my $address_decimal;
+ my $routine;
+
+ my $num_source_files = 0;
+ my $number_of_functions = 0;
+ my $number_of_unique_functions = 0;
+ my $number_of_non_unique_functions = 0;
+
+#------------------------------------------------------------------------------
+# Open the file generated using the -fsummary option.
+#------------------------------------------------------------------------------
+ open (FSUMMARY_FILE, "<", $FSUMMARY_FILE)
+ or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'");
+ gp_message ("debug", $subr_name, "opened file $FSUMMARY_FILE for reading");
+
+#------------------------------------------------------------------------------
+# This is the typical structure of the fsummary output:
+#
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Functions sorted by metric: Exclusive Total CPU Time
+#
+# <Total>
+# Exclusive Total CPU Time: 11.538 (100.0%)
+# Inclusive Total CPU Time: 11.538 (100.0%)
+# Size: 0
+# PC Address: 1:0x00000000
+# Source File: (unknown)
+# Object File: (unknown)
+# Load Object: <Total>
+# Mangled Name:
+# Aliases:
+#
+# a_function_name
+# Exclusive Total CPU Time: 4.003 ( 34.7%)
+# Inclusive Total CPU Time: 4.003 ( 34.7%)
+# Size: 715
+# PC Address: 2:0x00006c61
+# Source File: <absolute path to source file>
+# Object File: <object filename>
+# Load Object: <executable name>
+# Mangled Name:
+# Aliases:
+#
+# The previous block is repeated for every function.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Skip the header. The header is defined to end with a blank line.
+#------------------------------------------------------------------------------
+ while (<FSUMMARY_FILE>)
+ {
+ $line = $_;
+ chomp ($line);
+ if ($line =~ /^\s*$/)
+ {
+ last;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Process the remaining blocks. Note that the first line should be <Total>,
+# but this is currently not checked.
+#------------------------------------------------------------------------------
+ $i = 0;
+ $routine_flag = $TRUE;
+ while (<FSUMMARY_FILE>)
+ {
+ $line = $_;
+ chomp ($line);
+ gp_message ("debugXL", $subr_name, "line = $line");
+
+ if ($line =~ /^\s*$/)
+#------------------------------------------------------------------------------
+# Blank line.
+#------------------------------------------------------------------------------
+ {
+ $routine_flag = $TRUE;
+ $df_flag = 0;
+
+#------------------------------------------------------------------------------
+# Linux vDSO exception
+#
+# TBD: Check if still relevant.
+#------------------------------------------------------------------------------
+ if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS")
+ {
+ $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"};
+ }
+ $i++;
+ next;
+ }
+
+ if ($routine_flag)
+#------------------------------------------------------------------------------
+# Should be the first line after the blank line.
+#------------------------------------------------------------------------------
+ {
+ $routine = $line;
+ push (@{ $g_map_function_to_index{$routine} }, $i);
+ gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}");
+
+#------------------------------------------------------------------------------
+# In a later parsing phase we need to know how many fields there are in a
+# function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that
+# may show up in a function list.
+#
+# Here we determine the number of fields and store it.
+#------------------------------------------------------------------------------
+ my @fields_in_name = split (" ", $routine);
+ $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name);
+
+#------------------------------------------------------------------------------
+# This name may change if the function has multiple occurrences, but in any
+# case, at the end of this routine this component has the final name to be
+# used.
+#------------------------------------------------------------------------------
+ $function_info[$i]{"alt_name"} = $routine;
+ if (not exists ($g_function_occurrences{$routine}))
+ {
+ gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist");
+ $function_info[$i]{"routine"} = $routine;
+ $g_function_occurrences{$routine} = 1;
+
+ gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}");
+ }
+ else
+ {
+ gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already");
+ $function_info[$i]{"routine"} = $routine;
+ $g_function_occurrences{$routine} += 1;
+ if (not exists ($g_multi_count_function{$routine}))
+ {
+ $g_multi_count_function{$routine} = $TRUE;
+ }
+ my $msg = "g_function_occurrences{$routine} = " .
+ $g_function_occurrences{$routine};
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+#------------------------------------------------------------------------------
+# New: used when generating the index.
+#------------------------------------------------------------------------------
+ $function_info[$i]{"function length"} = length ($routine);
+ $function_info[$i]{"tag_id"} = create_function_tag ($i);
+ if (not exists ($g_function_tag_id{$routine}))
+ {
+ $g_function_tag_id{$routine} = create_function_tag ($i);
+ }
+ else
+ {
+
+#------------------------------------------------------------------------------
+## TBD HACK!!! CHECK!!!!!
+#------------------------------------------------------------------------------
+ $g_function_tag_id{$routine} = $i;
+ }
+
+ $routine_flag = $FALSE;
+ gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"});
+
+#------------------------------------------------------------------------------
+# The $functions_index hash contains an array. After an initial assignment,
+# other values that have been found are pushed onto the arrays.
+#------------------------------------------------------------------------------
+ if (not exists ($functions_index{$routine}))
+ {
+ $functions_index{$routine} = [$i];
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# Add the array index to the list
+#------------------------------------------------------------------------------
+ push (@{$functions_index{$routine}}, $i);
+ }
+ next;
+ }
+
+#------------------------------------------------------------------------------
+# Expected format of an input line:
+# Exclusive Total CPU Time: 4.003 ( 34.7%)
+# or:
+# Source File: <absolute_path>/name_of_source_file
+#------------------------------------------------------------------------------
+ if ( not ($line =~ /^(\s*)(.*):(\s+)([^\s]+|(.*))/))
+ {
+ my $msg = "unexpected line format in summary file $FSUMMARY_FILE line = $line";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ $whatever = $2;
+ $value = $4;
+ $function_info[$i]{$whatever} = $value;
+ if ($whatever =~ /Source File/)
+ {
+ if (!exists ($source_files{$value}))
+ {
+ $source_files{$value} = $TRUE;
+ $num_source_files++;
+ }
+ }
+
+ if ($whatever =~ /PC Address/)
+ {
+ my $segment;
+ my $offset;
+#------------------------------------------------------------------------------
+# The format of the address is assumed to be the following 2:0x000070a8
+# Note that the regex is pretty wide. This is from the original code and
+# could be made more specific:
+# if ($value =~ /\s*(\S+):(\S+)/)
+#------------------------------------------------------------------------------
+# if ($value =~ /\s*(\S+):(\S+)/)
+ if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/)
+ {
+ $segment = $1;
+ $offset = $2;
+#------------------------------------------------------------------------------
+# Convert to a base 10 number
+#------------------------------------------------------------------------------
+ $address_decimal = hex ($offset); # decimal
+#------------------------------------------------------------------------------
+# Construct the address field. Note that we use the hex address here.
+#------------------------------------------------------------------------------
+ $full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280
+
+ $function_info[$i]{"addressobj"} = $address_decimal;
+ $function_info[$i]{"addressobjtext"} = $full_address_field;
+ $addressobjtextm{$full_address_field} = $i; # $RI
+ }
+ if (not exists ($functions_address_and_index{$routine}{$value}))
+ {
+ $functions_address_and_index{$routine}{$value} = $i;
+ }
+ else
+ {
+ gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address");
+ }
+
+ $number_of_functions++;
+ }
+ }
+ close (FSUMMARY_FILE);
+
+#------------------------------------------------------------------------------
+# For every function in the function overview, set up an html structure with
+# the various hyperlinks.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "augment function_info with alt_name");
+ my $target_function;
+ my $html_line;
+ my $ftag;
+ my $routine_length;
+ my %html_source_functions = ();
+ for my $i (keys @function_info)
+ {
+ $target_function = $function_info[$i]{"routine"};
+
+ gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function");
+
+ my $href_link;
+## $href_link = "<a href=\'file." . $i . ".src.new.html#";
+ $href_link = "<a href=\'file." . $i . ".";
+ $href_link .= $g_html_base_file_name{"source"};
+ $href_link .= ".html#";
+ $href_link .= $function_info[$i]{"tag_id"};
+ $href_link .= "\'>source</a>";
+ $function_info[$i]{"href_source"} = $href_link;
+
+ $href_link = "<a href=\'file." . $i . ".";
+ $href_link .= $g_html_base_file_name{"disassembly"};
+ $href_link .= ".html#";
+ $href_link .= $function_info[$i]{"tag_id"};
+ $href_link .= "\'>disassembly</a>";
+ $function_info[$i]{"href_disassembly"} = $href_link;
+
+ $href_link = "<a href=\'";
+ $href_link .= $g_html_base_file_name{"caller_callee"};
+ $href_link .= ".html#";
+ $href_link .= $function_info[$i]{"tag_id"};
+ $href_link .= "\'>caller-callee</a>";
+ $function_info[$i]{"href_caller_callee"} = $href_link;
+
+ gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}");
+
+ if ($g_function_occurrences{$target_function} > 1)
+ {
+#------------------------------------------------------------------------------
+# In case a function occurs more than one time in the function overview, we
+# add the load object and address offset info to make it unique.
+#
+# This forces us to update some entries in function_info too.
+#------------------------------------------------------------------------------
+ my $loadobj = $function_info[$i]{"Load Object"};
+ my $address_field = $function_info[$i]{"addressobjtext"};
+ my $address_offset;
+
+#------------------------------------------------------------------------------
+# The address field has the following format: @<n>:<address_offset>
+# We only care about the address offset.
+#------------------------------------------------------------------------------
+ if ($address_field =~ /(^@\d*:*)(.+)/)
+ {
+ $address_offset = $2;
+ }
+ else
+ {
+ my $msg = "failed to extract the address offset from $address_field - use the full field";
+ gp_message ("warning", $subr_name, $msg);
+ $address_offset = $address_field;
+ }
+ my $exe = get_basename ($loadobj);
+ my $extra_field = " (<" . $exe . " $address_offset" .">)";
+### $target_function .= $extra_field;
+ $function_info[$i]{"alt_name"} = $target_function . $extra_field;
+ gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"});
+
+#------------------------------------------------------------------------------
+# Store the length of the function name and get the tag id.
+#------------------------------------------------------------------------------
+ $function_info[$i]{"function length"} = length ($target_function . $extra_field);
+ $function_info[$i]{"tag_id"} = create_function_tag ($i);
+
+ gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}");
+ gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
+ gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}");
+ gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}");
+ }
+ }
+ gp_message ("debug", $subr_name, "augment function_info with alt_name completed");
+
+#------------------------------------------------------------------------------
+# Compute the maximum function name length.
+#
+# The maximum length is stored in %function_view_structure.
+#------------------------------------------------------------------------------
+ my $max_function_length = 0;
+ for my $i (0 .. $#function_info)
+ {
+ $max_function_length = max ($max_function_length, $function_info[$i]{"function length"});
+
+ gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"});
+ }
+
+#------------------------------------------------------------------------------
+# Define the name of the table and take the length into account, since it may
+# be longer than the function name(s).
+#------------------------------------------------------------------------------
+ $function_view_structure{"table name"} = "Function name";
+
+ $max_function_length = max ($max_function_length, length ($function_view_structure{"table name"}));
+
+ $function_view_structure{"max function length"} = $max_function_length;
+
+#------------------------------------------------------------------------------
+# Core loop that generates an HTML line for each function. This line is
+# stored in function_info.
+#------------------------------------------------------------------------------
+ my $top_of_table = $FALSE;
+ for my $i (keys @function_info)
+ {
+ my $new_target_function;
+
+ if (defined ($function_info[$i]{"alt_name"}))
+ {
+ $target_function = $function_info[$i]{"alt_name"};
+ gp_message ("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
+ }
+ else
+ {
+ my $msg = "function_info[$i]{\"alt_name\"} is not defined";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ my $function_length = $function_info[$i]{"function length"};
+ my $number_of_blanks = $function_view_structure{"max function length"} - $function_length;
+
+ my $spaces = " ";
+ for my $i (1 .. $number_of_blanks)
+ {
+ $spaces .= " ";
+ }
+ if ($target_function eq "<Total>")
+#------------------------------------------------------------------------------
+# <Total> is a pseudo function and there is no source, or disassembly for it.
+# We could add a link to the caller-callee part, but this is currently not
+# done.
+#------------------------------------------------------------------------------
+ {
+ $top_of_table = $TRUE;
+ $html_line = " <b><Total></b>";
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# Add the * symbol as a marker in case the same function occurs multiple times.
+# Otherwise insert a space.
+#------------------------------------------------------------------------------
+ my $base_function_name = $function_info[$i]{"routine"};
+ if (exists ($g_function_occurrences{$base_function_name}))
+ {
+ if ($g_function_occurrences{$base_function_name} > 1)
+ {
+ $new_target_function = "*" . $target_function;
+ }
+ else
+ {
+ $new_target_function = " " . $target_function;
+ }
+ }
+ else
+ {
+ my $msg = "g_function_occurrences{$base_function_name} does not exist";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Create the block with the function name, in boldface, plus the links to the
+# source, disassembly and caller-callee views.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+ $html_line = "<b>$new_target_function</b>" . $spaces;
+ $html_line .= $function_info[$i]{"href_source"} . " ";
+ $html_line .= $function_info[$i]{"href_disassembly"} . " ";
+ $html_line .= $function_info[$i]{"href_caller_callee"};
+ }
+
+ gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line");
+ $html_source_functions{$target_function} = $html_line;
+
+#------------------------------------------------------------------------------
+# TBD: In the future we want to re-use this block elsewhere.
+#------------------------------------------------------------------------------
+ $function_info[$i]{"html function block"} = $html_line;
+ }
+
+ for my $i (keys %html_source_functions)
+ {
+ gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
+ }
+ for my $i (keys @function_info)
+ {
+ gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"});
+ }
+
+#------------------------------------------------------------------------------
+# Print the key data structure %function_info. This is a nested hash.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#function_info)
+ {
+ for my $role (sort keys %{ $function_info[$i] })
+ {
+ gp_message ("debug", $subr_name, "on return: function_info[$i]{$role} = $function_info[$i]{$role}");
+ }
+ }
+#------------------------------------------------------------------------------
+# Print the data structure %functions_address_and_index. This is a nested hash.
+#------------------------------------------------------------------------------
+ for my $F (keys %functions_address_and_index)
+ {
+ for my $fields (sort keys %{ $functions_address_and_index{$F} })
+ {
+ gp_message ("debug", $subr_name, "on return: functions_address_and_index{$F}{$fields} = $functions_address_and_index{$F}{$fields}");
+ }
+ }
+#------------------------------------------------------------------------------
+# Print the data structure %functions_index. This is a hash with an arrray.
+#------------------------------------------------------------------------------
+ for my $F (keys %functions_index)
+ {
+ gp_message ("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }");
+# alt code for my $i (0 .. $#{ $functions_index{$F} } )
+# alt code {
+# alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]");
+# alt code }
+ }
+
+#------------------------------------------------------------------------------
+# Print the data structure %function_view_structure. This is a hash.
+#------------------------------------------------------------------------------
+ for my $F (keys %function_view_structure)
+ {
+ gp_message ("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}");
+ }
+
+#------------------------------------------------------------------------------
+# Print the data structure %g_function_occurrences and use this structure to
+# gather statistics about the functions.
+#
+# TBD: add this info to the experiment data overview.
+#------------------------------------------------------------------------------
+ $number_of_unique_functions = 0;
+ $number_of_non_unique_functions = 0;
+ for my $F (keys %g_function_occurrences)
+ {
+ gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}");
+ if ($g_function_occurrences{$F} == 1)
+ {
+ $number_of_unique_functions++;
+ }
+ else
+ {
+ $number_of_non_unique_functions++;
+ }
+ }
+
+ for my $i (keys %g_map_function_to_index)
+ {
+ my $n = scalar (@{ $g_map_function_to_index{$i} });
+ gp_message ("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }");
+ }
+
+#------------------------------------------------------------------------------
+# TBD: Include in experiment data. Include names with multiple occurrences.
+#------------------------------------------------------------------------------
+ my $msg;
+
+ $msg = "Number of source files : " .
+ $num_source_files;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "Total number of functions: $number_of_functions";
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "Number of functions functions with a unique name : " .
+ $number_of_unique_functions;
+ gp_message ("debug", $subr_name, $msg);
+ $msg = "Number of functions functions with more than one occurrence : " .
+ $number_of_non_unique_functions;
+ gp_message ("debug", $subr_name, $msg);
+ my $multi_occurrences = $number_of_functions - $number_of_unique_functions;
+ $msg = "Total number of multiple occurences of the same function name : " .
+ $multi_occurrences;
+ gp_message ("debug", $subr_name, $msg);
+
+ return (\@function_info, \%functions_address_and_index, \%addressobjtextm, \%LINUX_vDSO, \%function_view_structure);
+
+} #-- End of subroutine get_function_info
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub get_hdr_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir, $file) = @_;
+
+ state $first_call = $TRUE;
+
+ my $ASORTFILE;
+ my @HDR;
+ my $HDR;
+ my $metric;
+ my $line;
+ my $ignore_directory;
+ my $ignore_suffix;
+ my $number_of_header_lines;
+
+#------------------------------------------------------------------------------
+# Add a "/" to simplify the construction of path names in the remainder.
+#------------------------------------------------------------------------------
+ $outputdir = append_forward_slash ($outputdir);
+
+# Could get more header info from
+# <metric>[e.bit_fcount].sort.func file - etc.
+
+ gp_message ("debug", $subr_name, "input file->$file<-");
+#-----------------------------------------------
+ if ($file eq $outputdir."calls.sort.func")
+ {
+ $ASORTFILE=$outputdir."calls";
+ $metric = "calls"
+ }
+ elsif ($file eq $outputdir."calltree.sort.func")
+ {
+ $ASORTFILE=$outputdir."calltree";
+ $metric = "calltree"
+ }
+ elsif ($file eq $outputdir."functions.sort.func")
+ {
+ $ASORTFILE=$outputdir."functions.func";
+ $metric = "functions";
+ }
+ else
+ {
+ $ASORTFILE = $file;
+# $metric = basename ($file,".sort.func");
+ ($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func");
+ gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix");
+ }
+
+ gp_message ("debug", $subr_name, "file = $file metric = $metric");
+
+ open (ASORTFILE,"<", $ASORTFILE)
+ or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'");
+ gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading");
+
+ $number_of_header_lines = 0;
+ while (<ASORTFILE>)
+ {
+ $line =$_;
+ chomp ($line);
+
+ if ($line =~ /^Current/)
+ {
+ next;
+ }
+ if ($line =~ /^Functions/)
+ {
+ next;
+ }
+ if ($line =~ /^Callers/)
+ {
+ next;
+ }
+ if ($line =~ /^\s*$/)
+ {
+ next;
+ }
+ if (!($line =~ /^\s*\d/))
+ {
+ $HDR[$number_of_header_lines] = $line;
+ $number_of_header_lines++;
+ next;
+ }
+ last;
+ }
+ close (ASORTFILE);
+#-------------------------------------------------------------------------------
+# Ruud - Fixed a bug. The output should not be appended, but overwritten.
+# open (HI,">>$OUTPUTDIR"."hdrinfo");
+#-------------------------------------------------------------------------------
+ my $outfile = $outputdir."hdrinfo";
+
+ if ($first_call)
+ {
+ $first_call = $FALSE;
+ open (HI ,">", $outfile)
+ or die ("$subr_name - unable to open file $outfile for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+ }
+ else
+ {
+ open (HI ,">>", $outfile)
+ or die ("$subr_name - unable to open file $outfile in append mode: '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile in append mode");
+ }
+
+ print HI "\#$metric hdrlines=$number_of_header_lines\n";
+ my $len = 0;
+ for $HDR (@HDR)
+ {
+ print HI "$HDR\n";
+ gp_message ("debugXL", $subr_name, "HDR = $HDR\n");
+ }
+ close (HI);
+ if ($first_call)
+ {
+ gp_message ("debug", $subr_name, "wrote file $outfile");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "updated file $outfile");
+ }
+#-----------------------------------------------
+
+} #-- End of subroutine get_hdr_info
+
+#------------------------------------------------------------------------------
+# Get the home directory and the location(s) of the configuration file on the
+# current system.
+#------------------------------------------------------------------------------
+sub get_home_dir_and_rc_path
+{
+ my $subr_name = get_my_name ();
+
+ my ($rc_file_name) = @_;
+
+ my @rc_file_paths;
+ my $target_cmd;
+ my $home_dir;
+ my $error_code;
+
+ $target_cmd = $g_mapped_cmds{"printenv"} . " HOME";
+
+ ($error_code, $home_dir) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+ {
+ my $msg = "cannot find a setting for HOME - please set this";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ else
+
+#------------------------------------------------------------------------------
+# The home directory is known and we can define the locations for the
+# configuration file.
+#------------------------------------------------------------------------------
+ {
+ @rc_file_paths = (".", "$home_dir");
+ }
+
+ gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths");
+
+ return ($home_dir, \@rc_file_paths);
+
+} #-- End of subroutine get_home_dir_and_rc_path
+
+#------------------------------------------------------------------------------
+# This subroutine generates a list with the hot functions.
+#------------------------------------------------------------------------------
+sub get_hot_functions
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my $cmd_output;
+ my $error_code;
+ my $expr_name;
+ my $first_metric;
+ my $gp_display_text_cmd;
+ my $ignore_value;
+
+ my @sort_fields = ();
+
+ $expr_name = join (" ", @exp_dir_list);
+
+ gp_message ("debug", $subr_name, "expr_name = $expr_name");
+
+ my $outputdir = append_forward_slash ($input_string);
+
+ my $script_file = $outputdir."gp-fsummary.script";
+ my $outfile = $outputdir."gp-fsummary.out";
+ my $result_file = $outputdir."gp-fsummary.stderr";
+ my $gp_error_file = $outputdir.$g_gp_error_logfile;
+
+ @sort_fields = split (":", $summary_metrics);
+
+#------------------------------------------------------------------------------
+# This is extremely unlikely to happen, but if so, it is a fatal error.
+#------------------------------------------------------------------------------
+ my $number_of_elements = scalar (@sort_fields);
+
+ gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements");
+
+ if ($number_of_elements == 0)
+ {
+ my $msg = "there are $number_of_elements in the metrics list";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Get the summary of the hot functions
+#------------------------------------------------------------------------------
+ open (SCRIPT, ">", $script_file)
+ or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
+ gp_message ("debug", $subr_name, "opened script file $script_file for writing");
+
+#------------------------------------------------------------------------------
+# TBD: Check what this is about:
+# Attributed User CPU Time=a.user : for calltree - see P37 in manual
+#------------------------------------------------------------------------------
+ print SCRIPT "# limit 0\n";
+ print SCRIPT "limit 0\n";
+ print SCRIPT "# metrics $summary_metrics\n";
+ print SCRIPT "metrics $summary_metrics\n";
+ print SCRIPT "# thread_select all\n";
+ print SCRIPT "thread_select all\n";
+
+#------------------------------------------------------------------------------
+# Use first out of summary metrics as first (it doesn't matter which one)
+# $first_metric = (split /:/,$summary_metrics)[0];
+#------------------------------------------------------------------------------
+
+ $first_metric = $sort_fields[0];
+
+ print SCRIPT "# outfile $outfile\n";
+ print SCRIPT "outfile $outfile\n";
+ print SCRIPT "# sort $first_metric\n";
+ print SCRIPT "sort $first_metric\n";
+ print SCRIPT "# fsummary\n";
+ print SCRIPT "fsummary\n";
+
+ close SCRIPT;
+
+ my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name";
+
+ gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions");
+
+ $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
+
+ ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", $subr_name, "execution terminated");
+ my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd";
+ gp_message ("abort", $subr_name, $msg);
+ }
+
+ return ($outfile,\@sort_fields);
+
+} #-- End of subroutine get_hot_functions
+
+#------------------------------------------------------------------------------
+# For a given function name, return the index into "function_info". This
+# index gives access to all the meta data for the input function.
+#------------------------------------------------------------------------------
+sub get_index_function_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($routine_ref, $hex_address_ref, $function_info_ref) = @_;
+
+ my $routine = ${ $routine_ref };
+ my $hex_address = ${ $hex_address_ref };
+ my @function_info = @{ $function_info_ref };
+
+#------------------------------------------------------------------------------
+# Check if this function has multiple occurrences.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "check for multiple occurrences");
+
+ my $current_address = $hex_address;
+ my $alt_name = $routine;
+
+ my $found_a_match;
+ my $index_into_function_info;
+ my $target_tag;
+
+ if (not exists ($g_multi_count_function{$routine}))
+ {
+#------------------------------------------------------------------------------
+# There is only a single occurrence and it is straightforward to get the tag.
+#--------------------------------------------------------------------------
+## push (@final_function_names, $routine);
+ if (exists ($g_map_function_to_index{$routine}))
+ {
+ $index_into_function_info = $g_map_function_to_index{$routine}[0];
+ }
+ else
+ {
+ my $msg = "no entry for $routine in g_map_function_to_index";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# The function name has more than one occurrence and we need to find the one
+# that matches with the address.
+#------------------------------------------------------------------------------
+ $found_a_match = $FALSE;
+ gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
+ for my $ref (keys @{ $g_map_function_to_index{$routine} })
+ {
+ my $ref_index = $g_map_function_to_index{$routine}[$ref];
+ my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
+
+ gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
+ gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset");
+
+#------------------------------------------------------------------------------
+# TBD: Do this substitution when storing "addressobjtext" in function_info.
+#------------------------------------------------------------------------------
+ $addr_offset =~ s/^@\d+://;
+ gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset");
+ if ($addr_offset eq $current_address)
+ {
+ $found_a_match = $TRUE;
+ $index_into_function_info = $ref_index;
+ last;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# If there is no match, something has gone really wrong and we bail out.
+#------------------------------------------------------------------------------
+ if (not $found_a_match)
+ {
+ my $msg = "cannot find the mapping in function_info for function $routine";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+
+ return (\$index_into_function_info);
+
+} #-- End of subroutine get_index_function_info
+
+#-------------------------------------------------------------------------------
+# Get the setting for LANG, or assign a default if it is not set.
+#-------------------------------------------------------------------------------
+sub get_LANG_setting
+{
+ my $subr_name = get_my_name ();
+
+ my $error_code;
+ my $lang_setting;
+ my $target_cmd;
+ my $command_string;
+ my $LANG;
+
+ $target_cmd = $g_mapped_cmds{"printenv"};
+#------------------------------------------------------------------------------
+# Use the printenv command to get the settings for LANG.
+#------------------------------------------------------------------------------
+ if ($target_cmd eq "road_to_nowhere")
+ {
+ $error_code = 1;
+ }
+ else
+ {
+ $command_string = $target_cmd . " LANG";
+ ($error_code, $lang_setting) = execute_system_cmd ($command_string);
+ }
+
+ if ($error_code == 0)
+ {
+ chomp ($lang_setting);
+ $LANG = $lang_setting;
+ }
+ else
+ {
+ $LANG = $g_default_setting_lang;
+ my $msg = "cannot find a setting for LANG - use a default setting";
+ gp_message ("warning", $subr_name, $msg);
+ }
+
+ return ($LANG);
+
+} #-- End of subroutine get_LANG_setting
+
+#------------------------------------------------------------------------------
+# This subroutine gathers the basic information about the metrics.
+#------------------------------------------------------------------------------
+sub get_metrics_data
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my $cmd_options;
+ my $cmd_output;
+ my $error_code;
+ my $expr_name;
+ my $metrics_cmd;
+ my $metrics_output;
+ my $target_cmd;
+
+ $expr_name = join (" ", @exp_dir_list);
+
+ gp_message ("debug", $subr_name, "expr_name = $expr_name");
+
+#------------------------------------------------------------------------------
+# 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.
+#------------------------------------------------------------------------------
+ $cmd_options = " -viewmode machine -compare off -thread_select all";
+ $cmd_options .= " -outfile $outfile2";
+ $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name";
+
+ $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file";
+
+ gp_message ("debug", $subr_name, "command used to gather the information:");
+ gp_message ("debug", $subr_name, $metrics_cmd);
+
+ ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd);
+
+#------------------------------------------------------------------------------
+# Error handling. Any error that occurred is fatal and execution
+# should be aborted by the caller.
+#------------------------------------------------------------------------------
+ if ($error_code == 0)
+ {
+ gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2");
+ }
+ else
+ {
+ $target_cmd = $g_mapped_cmds{"cat"} . " $error_file";
+
+ ($error_code, $cmd_output) = execute_system_cmd ($target_cmd);
+
+ chomp ($cmd_output);
+
+ gp_message ("error", $subr_name, "contents of file $error_file:");
+ gp_message ("error", $subr_name, $cmd_output);
+ }
+
+ return ($error_code);
+
+} #-- End of subroutine get_metrics_data
+
+#------------------------------------------------------------------------------
+# Wrapper that returns the last part of the subroutine name. The assumption is
+# that the last part of the input name is of the form "aa::bb" or just "bb".
+#------------------------------------------------------------------------------
+sub get_my_name
+{
+ my $called_by = (caller (1))[3];
+ my @parts = split ("::", $called_by);
+ return ($parts[$#parts]);
+
+## my ($the_full_name_ref) = @_;
+
+## my $the_full_name = ${ $the_full_name_ref };
+## my $last_part;
+
+#------------------------------------------------------------------------------
+# If the regex below fails, use the full name."
+#------------------------------------------------------------------------------
+## $last_part = $the_full_name;
+
+#------------------------------------------------------------------------------
+# Capture the last part if there are multiple parts separated by "::".
+#------------------------------------------------------------------------------
+## if ($the_full_name =~ /.*::(.+)$/)
+## {
+## if (defined ($1))
+## {
+## $last_part = $1;
+## }
+## }
+
+## return (\$last_part);
+
+} #-- End of subroutine get_my_name
+
+#-------------------------------------------------------------------------------
+# Determine the characteristics of the current system
+#-------------------------------------------------------------------------------
+sub get_system_config_info
+{
+#------------------------------------------------------------------------------
+# The output from the "uname" command is used for this. Although not all of
+# these are currently used, we store all fields in separate variables.
+#------------------------------------------------------------------------------
+#
+#------------------------------------------------------------------------------
+# The options supported on uname from GNU coreutils 8.22:
+#------------------------------------------------------------------------------
+# -a, --all print all information, in the following order,
+# except omit -p and -i if unknown:
+# -s, --kernel-name print the kernel name
+# -n, --nodename print the network node hostname
+# -r, --kernel-release print the kernel release
+# -v, --kernel-version print the kernel version
+# -m, --machine print the machine hardware name
+# -p, --processor print the processor type or "unknown"
+# -i, --hardware-platform print the hardware platform or "unknown"
+# -o, --operating-system print the operating system
+#------------------------------------------------------------------------------
+# Sample output:
+# Linux ruudvan-vm-2-8-20200701 4.14.35-2025.400.8.el7uek.x86_64 #2 SMP Wed Aug 26 12:22:05 PDT 2020 x86_64 x86_64 x86_64 GNU/Linux
+#------------------------------------------------------------------------------
+ my $subr_name = get_my_name ();
+
+ my $target_cmd;
+ my $hostname_current;
+ my $error_code;
+ my $ignore_output;
+#------------------------------------------------------------------------------
+# Test once if the command succeeds. This avoids we need to check every
+# specific # command below.
+#------------------------------------------------------------------------------
+ $target_cmd = $g_mapped_cmds{uname};
+ ($error_code, $ignore_output) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+#-------------------------------------------------------------------------------
+# This is unlikely to happen, but you never know.
+#-------------------------------------------------------------------------------
+ {
+ gp_message ("abort", $subr_name, "failure to execute the uname command");
+ }
+
+ my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name);
+ my $nodename = qx ($target_cmd -n); chomp ($nodename);
+ my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release);
+ my $kernel_version = qx ($target_cmd -v); chomp ($kernel_version);
+ my $machine = qx ($target_cmd -m); chomp ($machine);
+ my $processor = qx ($target_cmd -p); chomp ($processor);
+ my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform);
+ my $operating_system = qx ($target_cmd -o); chomp ($operating_system);
+
+ $local_system_config{"kernel_name"} = $kernel_name;
+ $local_system_config{"nodename"} = $nodename;
+ $local_system_config{"kernel_release"} = $kernel_release;
+ $local_system_config{"kernel_version"} = $kernel_version;
+ $local_system_config{"machine"} = $machine;
+ $local_system_config{"processor"} = $processor;
+ $local_system_config{"hardware_platform"} = $hardware_platform;
+ $local_system_config{"operating_system"} = $operating_system;
+
+ gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:");
+ gp_message ("debug", $subr_name, "kernel_name = $kernel_name");
+ gp_message ("debug", $subr_name, "nodename = $nodename");
+ gp_message ("debug", $subr_name, "kernel_release = $kernel_release");
+ gp_message ("debug", $subr_name, "kernel_version = $kernel_version");
+ gp_message ("debug", $subr_name, "machine = $machine");
+ gp_message ("debug", $subr_name, "processor = $processor");
+ gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform");
+ gp_message ("debug", $subr_name, "operating_system = $operating_system");
+
+#------------------------------------------------------------------------------
+# Check if the system we are running on is supported.
+#------------------------------------------------------------------------------
+ my $is_supported = ${ check_support_for_processor (\$machine) };
+
+ if (not $is_supported)
+ {
+ gp_message ("error", $subr_name, "$machine is not supported");
+ exit (0);
+ }
+#------------------------------------------------------------------------------
+# The current hostname is used to compare against the hostname(s) found in the
+# experiment directories.
+#------------------------------------------------------------------------------
+ $target_cmd = $g_mapped_cmds{hostname};
+ $hostname_current = qx ($target_cmd); chomp ($hostname_current);
+ $error_code = ${^CHILD_ERROR_NATIVE};
+
+ if ($error_code == 0)
+ {
+ $local_system_config{"hostname_current"} = $hostname_current;
+ }
+ else
+#-------------------------------------------------------------------------------
+# This is unlikely to happen, but you never know.
+#-------------------------------------------------------------------------------
+ {
+ gp_message ("abort", $subr_name, "failure to execute the hostname command");
+ }
+ for my $key (sort keys %local_system_config)
+ {
+ gp_message ("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}");
+ }
+
+ return (0);
+
+} #-- End of subroutine get_system_config_info
+
+#-------------------------------------------------------------------------------
+# This subroutine prints a message. Several types of messages are supported.
+# In case the type is "abort", or "error", execution is terminated.
+#
+# Note that "debug", "warning", and "error" mode, the name of the calling
+# subroutine is truncated to 30 characters. In case the name is longer,
+# a warning message # is issued so you know this has happened.
+#
+# Note that we use lcfirst () and ucfirst () to enforce whether the first
+# character is printed in lower or uppercase. It is nothing else than a
+# convenience, but creates more consistency across messages.
+#-------------------------------------------------------------------------------
+sub gp_message
+{
+ my $subr_name = get_my_name ();
+
+ my ($action, $caller_name, $comment_line) = @_;
+
+#-------------------------------------------------------------------------------
+# The debugXL identifier is special. It is accepted, but otherwise ignored.
+# This allows to (temporarily) disable debug print statements, but keep them
+# around.
+#-------------------------------------------------------------------------------
+ my %supported_identifiers = (
+ "verbose" => "[Verbose]",
+ "debug" => "[Debug]",
+ "error" => "[Error]",
+ "warning" => "[Warning]",
+ "abort" => "[Abort]",
+ "assertion" => "[Assertion error]",
+ "diag" => "",
+ );
+
+ my $debug_size;
+ my $identifier;
+ my $fixed_size_name;
+ my $string_limit = 30;
+ my $strlen = length ($caller_name);
+ my $trigger_debug = $FALSE;
+ my $truncated_name;
+ my $msg;
+
+ if ($action =~ /debug\s*(.+)/)
+ {
+ if (defined ($1))
+ {
+ my $orig_value = $1;
+ $debug_size = lc ($1);
+
+ if ($debug_size =~ /^s$|^m$|^l$|^xl$/)
+ {
+ if ($g_debug_size{$debug_size})
+ {
+#-------------------------------------------------------------------------------
+# All we need to know is whether a debug action is requested and whether the
+# size has been enabled. By setting $action to "debug", the code below is
+# simplified. Note that only using $trigger_debug below is actually sufficient.
+#-------------------------------------------------------------------------------
+ $trigger_debug = $TRUE;
+ }
+ }
+ else
+ {
+ die "$subr_name: debug size $orig_value is not supported";
+ }
+ $action = "debug";
+ }
+ }
+ elsif ($action eq "debug")
+ {
+ $trigger_debug = $TRUE;
+ }
+
+#-------------------------------------------------------------------------------
+# Catch any non-supported identifier.
+#-------------------------------------------------------------------------------
+ if (defined ($supported_identifiers{$action}))
+ {
+ $identifier = $supported_identifiers{$action};
+ }
+ else
+ {
+ die ("$subr_name - input error: $action is not supported");
+ }
+ if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off"))
+ {
+ $trigger_debug = $FALSE;
+ }
+
+#-------------------------------------------------------------------------------
+# Unconditionally buffer all warning messages. These are meant to be displayed
+# separately.
+#-------------------------------------------------------------------------------
+ if ($action eq "warning")
+ {
+ push (@g_warning_messages, ucfirst ($comment_line));
+ }
+
+#-------------------------------------------------------------------------------
+# Quick return in several cases. Note that "debug", "verbose", "warning", and
+# "diag" messages are suppressed in quiet mode, but "error", "abort" and
+# "assertion" always pass.
+#-------------------------------------------------------------------------------
+ if ((
+ ($action eq "verbose") and (not $g_verbose))
+ or (($action eq "debug") and (not $trigger_debug))
+ or (($action eq "verbose") and ($g_quiet))
+ or (($action eq "debug") and ($g_quiet))
+ or (($action eq "warning") and (not $g_warnings))
+ or (($action eq "diag") and ($g_quiet)))
+ {
+ return (0);
+ }
+
+#-------------------------------------------------------------------------------
+# In diag mode, just print the input line and nothing else.
+#-------------------------------------------------------------------------------
+ if ((
+ $action eq "debug")
+ or ($action eq "abort")
+ or ($action eq "warning")
+ or ($action eq "assertion")
+ or ($action eq "error"))
+ {
+#-------------------------------------------------------------------------------
+# Construct the string to be printed. Include an identifier and the name of
+# the function.
+#-------------------------------------------------------------------------------
+ if ($strlen > $string_limit)
+ {
+ $truncated_name = substr ($caller_name, 0, $string_limit);
+ $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name);
+ print "Warning in $subr_name - the name of the caller is: $caller_name\n";
+ print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n";
+ }
+ else
+ {
+ $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name);
+ }
+
+ if (($action eq "error") or ($action eq "abort"))
+#-------------------------------------------------------------------------------
+# Enforce that the message starts with a lowercase symbol. Since these are
+# user errors, the name of the routine is not shown. The same for "abort".
+# If you want to display the routine name too, use an assertion.
+#-------------------------------------------------------------------------------
+ {
+ printf ("%-9s %s\n", $identifier, lcfirst ($comment_line));
+ }
+ elsif ($action eq "assertion")
+#-------------------------------------------------------------------------------
+# Enforce that the message starts with a lowercase symbol.
+#-------------------------------------------------------------------------------
+ {
+ printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
+ }
+ elsif (($action eq "debug") and ($trigger_debug))
+#-------------------------------------------------------------------------------
+# Debug messages are printed "as is". Avoids issues when searching for them ;-)
+#-------------------------------------------------------------------------------
+ {
+ printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
+ }
+ else
+#-------------------------------------------------------------------------------
+# Enforce that the message starts with a lowercase symbol.
+#-------------------------------------------------------------------------------
+ {
+ printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line));
+ }
+ }
+ elsif ($action eq "verbose")
+#-------------------------------------------------------------------------------
+# The first character in the verbose message is capatilized.
+#-------------------------------------------------------------------------------
+ {
+ printf ("%s\n", ucfirst ($comment_line));
+ }
+ elsif ($action eq "diag")
+#-------------------------------------------------------------------------------
+# The diag messages are meant to be diagnostics. Only the comment line is
+# printed.
+#-------------------------------------------------------------------------------
+ {
+ printf ("%s\n", $comment_line);
+ return (0);
+ }
+
+#-------------------------------------------------------------------------------
+# Terminate execution in case the identifier is "abort".
+#-------------------------------------------------------------------------------
+ if (($action eq "abort") or ($action eq "assertion"))
+ {
+## print "ABORT temporarily disabled for testing purposes\n";
+ exit (-1);
+ }
+ else
+ {
+ return (0);
+ }
+
+} #-- End of subroutine gp_message
+
+#------------------------------------------------------------------------------
+# Dynamically load the modules needed. Returns a list with the modules that
+# could not be loaded.
+#------------------------------------------------------------------------------
+sub handle_module_availability
+{
+ my $subr_name = get_my_name ();
+
+#------------------------------------------------------------------------------
+# This is clunky at best, but there is a chicken egg problem here. For the
+# man page to be generated, the --help and --version options need to work,
+# but this part of the code only works if the "stat" function is available.
+# The "feature qw (state)" is required for the code to compile.
+#
+# TBD: Consider using global variables and to decouple parts of the option
+# handling.
+#;
+## my @modules_used = ("feature",
+## "File::stat",
+#------------------------------------------------------------------------------
+ my @modules_used = (
+ "List::Util",
+ "Cwd",
+ "File::Basename",
+ "POSIX",
+ "bignum");
+
+ my @missing_modules = ();
+ my $cmd;
+ my $result;
+
+#------------------------------------------------------------------------------
+# This loop checks for the availability of the modules and if so, imports
+# the module.
+#
+# The names of missing modules, if any, are stored and printed in the error
+# handling section below.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#modules_used)
+ {
+ my $m = $modules_used[$i];
+ if (eval "require $m;")
+ {
+ if ($m eq "feature")
+ {
+ $cmd = $m . "->import ( qw (state))";
+ }
+ elsif ($m eq "List::Util")
+ {
+ $cmd = $m . "->import ( qw (min max))";
+ }
+ else
+ {
+ $cmd = $m . "->import";
+ }
+ $cmd .= ";";
+ $result = eval ("$cmd");
+ }
+ else
+ {
+ push (@missing_modules, $m);
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Count the number of missing modules. It is upon the caller to decide what
+# to do in case of errors. Currently, execution is aborted.
+#------------------------------------------------------------------------------
+ my $errors = scalar (@missing_modules);
+
+ return (\$errors, \@missing_modules);
+
+} #-- End of subroutine handle_module_availability
+
+#------------------------------------------------------------------------------
+# Generate the HTML with the experiment summary.
+#------------------------------------------------------------------------------
+sub html_generate_exp_summary
+{
+ my $subr_name = get_my_name ();
+
+ my ($outputdir_ref, $experiment_data_ref) = @_;
+
+ my $outputdir = ${ $outputdir_ref };
+ my @experiment_data = @{ $experiment_data_ref };
+ my $file_title;
+ my $outfile;
+ my $page_title;
+ my $size_text;
+ my $position_text;
+ my $html_header;
+ my $html_home;
+ my $html_title_header;
+ my $html_acknowledgement;
+ my $html_end;
+ my @html_exp_table_data = ();
+ my $html_exp_table_data_ref;
+ my @table_execution_stats = ();
+ my $table_execution_stats_ref;
+
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+ $outputdir = append_forward_slash ($outputdir);
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+
+ $file_title = "Experiment information";
+ $page_title = "Experiment Information";
+ $size_text = "h2";
+ $position_text = "center";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home = ${ generate_home_link ("right") };
+
+ $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
+
+ $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html";
+ open (EXP_INFO, ">", $outfile)
+ or die ("unable to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ print EXP_INFO $html_header;
+ print EXP_INFO $html_home;
+ print EXP_INFO $html_title_header;
+
+ ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref);
+
+ @html_exp_table_data = @{ $html_exp_table_data_ref };
+ @table_execution_stats = @{ $table_execution_stats_ref };
+
+ print EXP_INFO "$_" for @html_exp_table_data;
+;
+## print EXP_INFO "<pre>\n";
+## print EXP_INFO "$_\n" for @html_caller_callee;
+## print EXP_INFO "</pre>\n";
+
+#-------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#-------------------------------------------------------------------------------
+ $html_home = ${ generate_home_link ("left") };
+ $html_acknowledgement = ${ create_html_credits () };
+ $html_end = ${ terminate_html_document () };
+
+ print EXP_INFO $html_home;
+ print EXP_INFO "<br>\n";
+ print EXP_INFO $html_acknowledgement;
+ print EXP_INFO $html_end;
+
+ close (EXP_INFO);
+
+ return (\@table_execution_stats);
+
+} #-- End of subroutine html_generate_exp_summary
+
+#-------------------------------------------------------------------------------
+# Generate the entries for the tables with the experiment info.
+#-------------------------------------------------------------------------------
+sub html_generate_table_data
+{
+ my $subr_name = get_my_name ();
+
+ my ($experiment_data_ref) = @_;
+
+ my @experiment_data = ();
+ my @html_exp_table_data = ();
+ my $html_line;
+## my $html_header_line;
+ my $entry_name;
+ my $key;
+ my $size_text;
+ my $position_text;
+ my $title_table_1;
+ my $title_table_2;
+ my $title_table_3;
+ my $title_table_summary;
+ my $html_table_title;
+
+ my @experiment_table_1_def = ();
+ my @experiment_table_2_def = ();
+ my @experiment_table_3_def = ();
+ my @exp_table_summary_def = ();
+ my @experiment_table_1 = ();
+ my @experiment_table_2 = ();
+ my @experiment_table_3 = ();
+ my @exp_table_summary = ();
+ my @exp_table_selection = ();
+
+ @experiment_data = @{ $experiment_data_ref };
+
+ for my $i (sort keys @experiment_data)
+ {
+ for my $fields (sort keys %{ $experiment_data[$i] })
+ {
+ gp_message ("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}");
+ }
+ }
+
+ $title_table_1 = "Target System Configuration";
+ $title_table_2 = "Experiment Statistics";
+ $title_table_3 = "Run Time Statistics";
+ $title_table_summary = "Main Statistics";
+
+ $size_text = "h3";
+ $position_text = "left";
+
+ push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"};
+ push @experiment_table_1_def, { name => "Hostname" , key => "hostname"};
+ push @experiment_table_1_def, { name => "Operating system", key => "OS"};
+ push @experiment_table_1_def, { name => "Architecture", key => "architecture"};
+ push @experiment_table_1_def, { name => "Page size", key => "page_size"};
+
+ push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"};
+ push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"};
+ push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"};
+ push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"};
+
+ push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
+## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"};
+ push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
+## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"};
+ push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"};
+## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"};
+
+ push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"};
+ push @exp_table_summary_def, { name => "Hostname" , key => "hostname"};
+ push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
+ push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
+ push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"};
+
+ $html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) };
+
+ push (@html_exp_table_data, $html_table_title);
+
+ @experiment_table_1 = @{ create_table (\@experiment_data, \@experiment_table_1_def) };
+
+ push (@html_exp_table_data, @experiment_table_1);
+
+ $html_table_title = ${ generate_a_header (\$title_table_2, \$size_text, \$position_text) };
+
+ push (@html_exp_table_data, $html_table_title);
+
+ @experiment_table_2 = @{ create_table (\@experiment_data, \@experiment_table_2_def) };
+
+ push (@html_exp_table_data, @experiment_table_2);
+
+ $html_table_title = ${ generate_a_header (\$title_table_3, \$size_text, \$position_text) };
+
+ push (@html_exp_table_data, $html_table_title);
+
+ @experiment_table_3 = @{ create_table (\@experiment_data, \@experiment_table_3_def) };
+
+ push (@html_exp_table_data, @experiment_table_3);
+
+ $html_table_title = ${ generate_a_header (\$title_table_summary, \$size_text, \$position_text) };
+
+ push (@exp_table_summary, $html_table_title);
+
+ @exp_table_selection = @{ create_table (\@experiment_data, \@exp_table_summary_def) };
+
+ push (@exp_table_summary, @exp_table_selection);
+
+ return (\@html_exp_table_data, \@exp_table_summary);
+
+} #-- End of subroutine html_generate_table_data
+
+#------------------------------------------------------------------------------
+# Generate the HTML text to print in case a file is empty.
+#------------------------------------------------------------------------------
+sub html_text_empty_file
+{
+ my $subr_name = get_my_name ();
+
+ my ($comment_ref, $error_file_ref) = @_;
+
+ my $comment;
+ my $error_file;
+ my $error_message;
+ my $file_title;
+ my $html_end;
+ my $html_header;
+ my $html_home;
+
+ my @html_empty_file = ();
+
+ $comment = ${ $comment_ref };
+ $error_file = ${ $error_file_ref };
+
+ $file_title = "File is empty";
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_end = ${ terminate_html_document () };
+ $html_home = ${ generate_home_link ("left") };
+
+ push (@html_empty_file, $html_header);
+
+ $error_message = "<b>" . $comment . "</b>";
+ $error_message = set_background_color_string ($error_message, $g_html_color_scheme{"error_message"});
+ push (@html_empty_file, $error_message);
+
+ if (not is_file_empty ($error_file))
+ {
+ $error_message = "<p><em>Check file $error_file for more information</em></p>";
+ }
+ push (@html_empty_file, $error_message);
+ push (@html_empty_file, $html_home);
+ push (@html_empty_file, "<br>");
+ push (@html_empty_file, $g_html_credits_line);
+ push (@html_empty_file, $html_end);
+
+ return (\@html_empty_file);
+
+} #-- End of subroutine html_text_empty_file
+
+#------------------------------------------------------------------------------
+# This subroutine checks if a file is empty and returns $TRUE or $FALSE.
+#------------------------------------------------------------------------------
+sub is_file_empty
+{
+ my $subr_name = get_my_name ();
+
+ my ($filename) = @_;
+
+ my $size;
+ my $file_stat;
+ my $is_empty;
+
+ chomp ($filename);
+
+ if (not -e $filename)
+ {
+#------------------------------------------------------------------------------
+# The return value is used in the caller. This is why we return the empty
+# string in case the file does not exist.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "filename = $filename not found");
+ $is_empty = $TRUE;
+ }
+ else
+ {
+ $file_stat = stat ($filename);
+ $size = $file_stat->size;
+ $is_empty = ($size == 0) ? $TRUE : $FALSE;
+ }
+
+ gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty");
+
+ return ($is_empty);
+
+} #-- End of subroutine is_file_empty
+
+#-------------------------------------------------------------------------------
+# TBD.
+#-------------------------------------------------------------------------------
+sub name_regex
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric_description_ref, $metrics, $field, $file) = @_;
+
+ my %metric_description = %{ $metric_description_ref };
+
+ my @splitted_metrics;
+ my $splitted_metrics;
+ my $m;
+ my $mf;
+ my $nf;
+ my $re;
+ my $Xre;
+ my $noPCfile;
+ my @reported_metrics;
+ my $reported_metrics;
+ my $hdr_regex;
+ my $hdr_href_regex;
+ my $hdr_src_regex;
+ my $new_metrics;
+ my $pre;
+ my $post;
+ my $rat;
+ my @moo = ();
+
+ my $gp_metrics_file;
+ my $gp_metrics_dir;
+ my $suffix_not_used;
+
+ my $is_calls = $FALSE;
+ my $is_calltree = $FALSE;
+
+ gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-");
+
+#-------------------------------------------------------------------------------
+# According to https://perldoc.perl.org/File::Basename, both dirname and
+# basename are not reliable and fileparse () is recommended instead.
+#
+# Note that $gp_metrics_dir has a trailing "/".
+#-------------------------------------------------------------------------------
+ ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC");
+
+ gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file");
+ gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
+
+ if ($gp_metrics_file eq "calls")
+ {
+ $is_calls = $TRUE;
+ }
+ if ($gp_metrics_file eq "calltree")
+ {
+ $is_calltree = $TRUE;
+ }
+
+ $gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC";
+ $gp_metrics_file = $gp_metrics_dir . $gp_metrics_file;
+
+ gp_message ("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file");
+
+ open (GP_METRICS, "<", $gp_metrics_file)
+ or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened file $gp_metrics_file for reading");
+
+ $new_metrics = $metrics;
+
+ while (<GP_METRICS>)
+ {
+ $rat = $_;
+ chomp ($rat);
+ gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics");
+#-------------------------------------------------------------------------------
+# Capture the string after "Current metrics:" and if it ends with ":name",
+# remove it.
+#-------------------------------------------------------------------------------
+ if ($rat =~ /^\s*Current metrics:\s*(.*)$/)
+ {
+ $new_metrics = $1;
+ if ($new_metrics =~ /^(.*):name$/)
+ {
+ $new_metrics = $1;
+ }
+ last;
+ }
+ }
+ close (GP_METRICS);
+
+ if ($is_calls or $is_calltree)
+ {
+#-------------------------------------------------------------------------------
+# Remove any inclusive metrics from the list.
+#-------------------------------------------------------------------------------
+ while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/)
+ {
+ $pre = $1;
+ $post = $3;
+ gp_message ("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post");
+ if (substr ($post,0,1) eq ":")
+ {
+ $post = substr ($post,1);
+ }
+ $new_metrics = $pre.$post;
+ }
+ }
+
+ $metrics = $new_metrics;
+
+ gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-");
+
+#-------------------------------------------------------------------------------
+# Find the line starting with "address:" and strip this part away.
+#-------------------------------------------------------------------------------
+ if ($metrics =~ /^address:(.*)/)
+ {
+ $reported_metrics = $1;
+#-------------------------------------------------------------------------------
+# Focus on the filename ending with "-PC". When found, strip this part away.
+#-------------------------------------------------------------------------------
+ if ($file =~ /^(.*)-PC$/)
+ {
+ $noPCfile = $1;
+ if ($noPCfile =~ /^(.*)functions.sort.func$/)
+ {
+ $noPCfile = $1."functions.func";
+ }
+ push (@moo, "$reported_metrics\n");
+ }
+ }
+
+#-------------------------------------------------------------------------------
+# Split the list into an array with the individual metrics.
+#
+# TBD: This should be done only once!
+#-------------------------------------------------------------------------------
+ @reported_metrics = split (":", $reported_metrics);
+ for my $i (@reported_metrics)
+ {
+ gp_message ("debugXL", $subr_name, "reported_metrics = $i");
+ }
+
+ $hdr_regex = "^\\s*";
+ $hdr_href_regex = "^\\s*";
+ $hdr_src_regex = "^(\\s+|<i>\\s+)";
+
+ for my $m (@reported_metrics)
+ {
+
+ my $description = ${ retrieve_metric_description (\$m, \%metric_description) };
+ gp_message ("debugXL", $subr_name, "m = $m description = $description");
+ if (substr ($m,0,1) eq "e")
+ {
+ push (@moo,"$m:$description\n");
+ $hdr_regex .= "(Excl\\.\.*)";
+ $hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)";
+ $hdr_src_regex .= "(Excl\\.\.*)";
+ next;
+ }
+ if (substr ($m,0,1) eq "i")
+ {
+ push (@moo,"$m:$description\n");
+ $hdr_regex .= "(Incl\\.\.*)";
+ $hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)";
+ $hdr_src_regex .= "(Incl\\.\.*)";
+ next;
+ }
+ if (substr ($m,0,1) eq "a")
+ {
+ my $a;
+ my $am;
+ $a = $m;
+ $a =~ s/^a/e/;
+ $am = ${ retrieve_metric_description (\$a, \%metric_description) };
+ $am =~ s/Exclusive/Attributed/;
+ push (@moo,"$m:$am\n");
+ $hdr_regex .= "(Attr\\.\.*)";
+ $hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)";
+ $hdr_src_regex .= "(Attr\\.\.*)";next;
+ }
+ }
+
+ $hdr_regex .= "(Name\.*)";
+ $hdr_href_regex .= "(Name\.*)";
+
+ @splitted_metrics = split (":","$metrics");
+ $nf = scalar (@splitted_metrics);
+ gp_message ("debug", $subr_name,"number of fields in $metrics -> $nf");
+
+ open (ZMETRICS, ">", "$noPCfile.metrics")
+ or die ("Not able to open file $noPCfile.metrics for writing - '$!'");
+ gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing");
+
+ print ZMETRICS @moo;
+ close (ZMETRICS);
+
+ gp_message ("debug", $subr_name, "wrote file $noPCfile.metrics");
+
+ open (XREGEXP, ">", "$noPCfile.c.regex")
+ or die ("Not able to open file $noPCfile.c.regex for writing - '$!'");
+ gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing");
+
+ print XREGEXP "\# Number of metric fields\n";
+ print XREGEXP "$nf\n";
+ print XREGEXP "\# Header regex\n";
+ print XREGEXP "$hdr_regex\n";
+ print XREGEXP "\# href Header regex\n";
+ print XREGEXP "$hdr_href_regex\n";
+ print XREGEXP "\# src Header regex\n";
+ print XREGEXP "$hdr_src_regex\n";
+
+ $mf = 1;
+#---------------------------------------------------------------------------
+# Find the index of "field" in the metric list, plus one.
+#---------------------------------------------------------------------------
+ if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree"))
+ {
+ $mf = $nf + 1;
+ }
+ else
+ {
+ for my $candidate_metric (@splitted_metrics)
+ {
+ gp_message ("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf");
+ if ($candidate_metric eq $field)
+ {
+ last;
+ }
+ $mf++;
+ }
+ }
+ gp_message ("debugXL", $subr_name, "Final value mf = $mf");
+
+ if ($mf == 1)
+ {
+ $re = "^\\s*(\\S+)"; # metric value
+ }
+ else
+ {
+ $re = "^\\s*\\S+";
+ }
+ $Xre = "^\\s*(\\S+)";
+
+ $m = 2;
+ while (--$nf)
+ {
+ if ($nf)
+ {
+ if ($m == $mf)
+ {
+ $re .= "\\s+(\\S+)"; # metric value
+ }
+ else
+ {
+ $re .= "\\s+\\S+";
+ }
+ if ($nf != 1)
+ {
+ $Xre .= "\\s+(\\S+)";
+ }
+ $m++;
+ }
+ }
+
+ if ($field eq "calltree")
+ {
+ $re .= "\\s+.*\\+-(.*)"; # name
+ $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?)
+ }
+ else
+ {
+ $re .= "\\s+(.*)"; # name
+ $Xre .= "\\s+(.*)\$"; # name
+ }
+
+ print XREGEXP "\# Metrics and Name regex\n";
+ print XREGEXP "$Xre\n";
+ close (XREGEXP);
+
+ gp_message ("debug", $subr_name, "wrote file $noPCfile.c.regex");
+ gp_message ("debugXL", $subr_name, "on return Xre = $Xre");
+ gp_message ("debugXL", $subr_name, "on return re = $re");
+
+ return ($re);
+
+} #-- End of subroutine name_regex
+
+#-------------------------------------------------------------------------------
+# TBD
+#-------------------------------------------------------------------------------
+sub nosrc
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_string) = @_;
+
+ my $directory_name = append_forward_slash ($input_string);
+ my $LANG = $g_locale_settings{"LANG"};
+ my $result_file = $directory_name."no_source.html";
+
+ gp_message ("debug", $subr_name, "result_file = $result_file");
+
+ open (NS, ">", $result_file)
+ or die ("$subr_name: cannot open file $result_file for writing - '$!'");
+
+ print NS "<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n".
+ "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
+ "<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n";
+ print NS "<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font
+ print NS "</pre>\n<pre>Output generated by $version_info</pre>\n";
+ print NS "</body></html>\n";
+
+ close (NS);
+
+ return (0);
+
+} #-- End of subroutine nosrc
+
+#------------------------------------------------------------------------------
+# TBD.
+#------------------------------------------------------------------------------
+sub numerically
+{
+ my $f1;
+ my $f2;
+
+ if ($a =~ /^([^\d]*)(\d+)/)
+ {
+ $f1 = int ($2);
+ if ($b=~ /^([^\d]*)(\d+)/)
+ {
+ $f2 = int ($2);
+ $f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1);
+ }
+ }
+ else
+ {
+ return ($a <=> $b);
+ }
+} #-- End of subroutine numerically
+
+#------------------------------------------------------------------------------
+# Parse the user options. Also perform a basic check. More checks and also
+# some specific to the option will be performed after this subroutine.
+#------------------------------------------------------------------------------
+sub parse_and_check_user_options
+{
+ my $subr_name = get_my_name ();
+
+ my ($no_of_args_ref, $option_list_ref) = @_;
+
+ my $no_of_args = ${ $no_of_args_ref };
+ my @option_list = @{ $option_list_ref };
+
+ my @exp_dir_list;
+
+ my $arg;
+ my $calltree_value;
+ my $debug_value;
+ my $default_metrics_value;
+ my $func_limit_value;
+ my $found_exp_dir = $FALSE;
+ my $ignore_metrics_value;
+ my $ignore_value;
+ my $message;
+ my $outputdir_value;
+ my $quiet_value;
+ my $hp_value;
+ my $valid;
+ my $verbose_value;
+
+ $no_of_args++;
+
+ gp_message ("debug", $subr_name, "no_of_args = $no_of_args");
+ gp_message ("debug", $subr_name, "option_list = @option_list");
+
+ my $option_errors = 0;
+
+ while (defined ($arg = shift @ARGV))
+ {
+ gp_message ("debug", $subr_name, "parsing options arg = $arg");
+ gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV");
+
+#------------------------------------------------------------------------------
+# The gprofng driver adds this option. We need to get rid of it.
+#------------------------------------------------------------------------------
+ next if ($arg eq "--whoami=gprofng display html");
+
+#------------------------------------------------------------------------------
+# Parse the input options and check for the values to be valid.
+#
+# Valid values are stored in the main option table.
+#
+# TBD: The early check handles some of these already and the duplicates
+# can be removed. Be aware of some global settings though.
+#------------------------------------------------------------------------------
+ if ($arg eq "--version")
+ {
+ print_version_info ();
+ exit (0);
+ }
+ elsif ($arg eq "--help")
+ {
+ $ignore_value = print_help_info ();
+ exit (0);
+ }
+ elsif (($arg eq "-v") or ($arg eq "--verbose"))
+ {
+ $verbose_value = shift @ARGV;
+ $valid = check_user_option ("verbose", $verbose_value);
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+ else
+ {
+ $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
+ }
+ next;
+ }
+ elsif (($arg eq "-w") or ($arg eq "--warnings"))
+ {
+ my $warnings_value = shift @ARGV;
+ $valid = check_user_option ("warnings", $warnings_value);
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+ else
+ {
+ $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
+ }
+ next;
+ }
+ elsif (($arg eq "-d") or ($arg eq "--debug"))
+ {
+ $debug_value = shift @ARGV;
+ $valid = check_user_option ("debug", $debug_value);
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# This function internally converts the value to uppercase.
+#------------------------------------------------------------------------------
+ my $ignore_value = set_debug_size (\$debug_value);
+ }
+ next;
+ }
+ elsif (($arg eq "-q") or ($arg eq "--quiet"))
+ {
+ $quiet_value = shift @ARGV;
+ $valid = check_user_option ("quiet", $quiet_value);
+
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+ else
+ {
+ $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
+ }
+ next;
+ }
+ elsif (($arg eq "-o") or ($arg eq "--output"))
+ {
+ $outputdir_value = shift @ARGV;
+ $valid = check_user_option ("output", $outputdir_value);
+
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+
+ next;
+ }
+ elsif (($arg eq "-O") or ($arg eq "--overwrite"))
+ {
+ $outputdir_value = shift @ARGV;
+ $valid = check_user_option ("overwrite", $outputdir_value);
+
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+
+ next;
+ }
+ elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage"))
+ {
+ $hp_value = shift @ARGV;
+ $valid = check_user_option ("highlight_percentage", $hp_value);
+
+ if (not $valid)
+ {
+ $option_errors++;
+ }
+
+ next;
+ }
+# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit"))
+# Temporarily disabled {
+# Temporarily disabled $func_limit_value = shift @ARGV;
+# Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value);
+# Temporarily disabled
+# Temporarily disabled if (not $valid)
+# Temporarily disabled {
+# Temporarily disabled $option_errors++;
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled next;
+# Temporarily disabled }
+# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree"))
+# Temporarily disabled {
+# Temporarily disabled $calltree_value = shift @ARGV;
+# Temporarily disabled $valid = check_user_option ("calltree", $calltree_value);
+# Temporarily disabled
+# Temporarily disabled if (not $valid)
+# Temporarily disabled {
+# Temporarily disabled $option_errors++;
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled next;
+# Temporarily disabled }
+# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage"))
+# Temporarily disabled {
+# Temporarily disabled $tp_value = shift @ARGV;
+# Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value);
+# Temporarily disabled
+# Temporarily disabled if (not $valid)
+# Temporarily disabled {
+# Temporarily disabled $option_errors++;
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled next;
+# Temporarily disabled }
+# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics"))
+# Temporarily disabled {
+# Temporarily disabled $default_metrics_value = shift @ARGV;
+# Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value);
+# Temporarily disabled
+# Temporarily disabled if (not $valid)
+# Temporarily disabled {
+# Temporarily disabled $option_errors++;
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled next;
+# Temporarily disabled }
+# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics"))
+# Temporarily disabled {
+# Temporarily disabled $ignore_metrics_value = shift @ARGV;
+# Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value);
+# Temporarily disabled
+# Temporarily disabled if (not $valid)
+# Temporarily disabled {
+# Temporarily disabled $option_errors++;
+# Temporarily disabled }
+# Temporarily disabled
+# Temporarily disabled next;
+# Temporarily disabled }
+ else
+ {
+
+#------------------------------------------------------------------------------
+# When we get to this part of the code it means that the current command line
+# argument is not a known option.
+#
+# We check if it is the name of an experiment directory and if so, add it to
+# the list with directories to use.
+#
+# If not, print an error message and increment the error variable because this
+# is clearly something that is not right.
+#-------------------------------------------------------------------------------
+
+ if ($arg =~ /^\-.*/)
+ {
+#-------------------------------------------------------------------------------
+# It is an option, but not a supported one. Print a message and increment
+# the error count.
+#-------------------------------------------------------------------------------
+ $message = "option $arg is not a known option";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+ }
+ else
+ {
+#-------------------------------------------------------------------------------
+# Other than options, the input has to consist of at least one directory name.
+# First remove any trailing slashes (/) and then check if the name is valid.
+#-------------------------------------------------------------------------------
+ $arg =~ s/\/*\/$//;
+ if ($arg =~ /.+\.er$/)
+ {
+#-------------------------------------------------------------------------------
+# It is the name of an experiment directory and is added to the list.
+#-------------------------------------------------------------------------------
+ $found_exp_dir = $TRUE;
+ push (@exp_dir_list, $arg);
+ }
+ else
+ {
+#-------------------------------------------------------------------------------
+# It is not a valid experiment directory name. Print a message and exit.
+#-------------------------------------------------------------------------------
+ $message = "not a valid experiment directory name: $arg";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+ }
+ }
+
+ } #-- End of last else
+
+ } #-- End of while-loop
+
+#-------------------------------------------------------------------------------
+# Check if the name of the experiment directories is valid. Note that later
+# we check for these directories to exist.
+#-------------------------------------------------------------------------------
+ if (not $found_exp_dir)
+ {
+ $message = "experiment directory name(s) are either not valid, or missing";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+ }
+
+#------------------------------------------------------------------------------
+# Check for fatal errors to have occurred. If so, stop execution. Otherwise,
+# confirm the verbose setting.
+#------------------------------------------------------------------------------
+ if ($option_errors > 0)
+ {
+ gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "no errors in the options found");
+ }
+
+ return ($option_errors, $found_exp_dir, \@exp_dir_list);
+
+} #-- End of subroutine parse_and_check_user_options
+
+#------------------------------------------------------------------------------
+# Parse the generated .dis files
+#------------------------------------------------------------------------------
+sub parse_dis_files
+{
+ my $subr_name = get_my_name ();
+
+ my ($number_of_metrics_ref, $function_info_ref,
+ $functions_address_and_index_ref, $input_string_ref,
+ $addressobj_index_ref) = @_;
+
+#------------------------------------------------------------------------------
+# Note that $functions_address_and_index_ref are is not used,
+# but we need to pass in the address into generate_dis_html.
+#------------------------------------------------------------------------------
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my $input_string = ${ $input_string_ref };
+ my %addressobj_index = %{ $addressobj_index_ref };
+
+#------------------------------------------------------------------------------
+# The regex section.
+#------------------------------------------------------------------------------
+ my $dis_filename_id_regex = 'file\.([0-9]+)\.dis';
+
+ my $filename;
+ my $outputdir = append_forward_slash ($input_string);
+
+ my @source_line = ();
+ my $source_line_ref;
+
+ my @metric = ();
+ my $metric_ref;
+
+ my $target_function;
+
+ gp_message ("debug", $subr_name, "building disassembly files");
+ gp_message ("debug", $subr_name, "outputdir = $outputdir");
+
+ while (glob ($outputdir.'*.dis'))
+ {
+ gp_message ("debug", $subr_name, "processing disassembly file: $_");
+
+ my $base_name = get_basename ($_);
+
+ if ($base_name =~ /$dis_filename_id_regex/)
+ {
+ if (defined ($1))
+ {
+ gp_message ("debug", $subr_name, "processing disassembly file: $base_name $1");
+ if (exists ($function_info[$1]{"routine"}))
+ {
+ $target_function = $function_info[$1]{"routine"};
+ gp_message ("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function");
+ }
+ if (exists ($g_function_tag_id{$target_function}))
+ {
+ gp_message ("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}");
+ }
+ else
+ {
+ my $msg = "no function tag found for $target_function";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id");
+ }
+ }
+
+ $filename = $_;
+ gp_message ("verbose", $subr_name, " Processing disassembly file $filename");
+ ($source_line_ref, $metric_ref) = generate_dis_html (
+ \$target_function,
+ \$number_of_metrics,
+ $function_info_ref,
+ $functions_address_and_index_ref,
+ \$outputdir,
+ \$filename,
+ \@source_line,
+ \@metric,
+ \%addressobj_index);
+
+ @source_line = @{ $source_line_ref };
+ @metric = @{ $metric_ref };
+ }
+
+ return (0)
+
+} #-- End of subroutine parse_dis_files
+
+#------------------------------------------------------------------------------
+# Parse the .src.txt files
+#------------------------------------------------------------------------------
+sub parse_source_files
+{
+ my $subr_name = get_my_name ();
+
+ my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_;
+
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my $outputdir = ${ $outputdir_ref };
+ my $ignore_value;
+
+ my $outputdir_with_slash = append_forward_slash ($outputdir);
+
+ gp_message ("verbose", $subr_name, "building source files");
+
+ while (glob ($outputdir_with_slash.'*.src.txt'))
+ {
+ gp_message ("verbose", $subr_name, " Processing source file: $_");
+ gp_message ("debug", $subr_name, "processing source file: $_");
+
+ my $found_target = process_source (
+ $number_of_metrics,
+ $function_info_ref,
+ $outputdir_with_slash,
+ $_);
+
+ if (not $found_target)
+ {
+ gp_message ("debug", $subr_name, "target function not found");
+ }
+ }
+
+} #-- End of subroutine parse_source_files
+
+#------------------------------------------------------------------------------
+# Routine to prepend \\ to selected symbols.
+#------------------------------------------------------------------------------
+sub prepend_backslashes
+{
+ my $subr_name = get_my_name ();
+
+ my ($target_string) = @_;
+
+ gp_message ("debug", $subr_name, "target_string on entry = $target_string");
+
+ $target_string =~ s/\(/\\\(/g;
+ $target_string =~ s/\)/\\\)/g;
+ $target_string =~ s/\+/\\\+/g;
+ $target_string =~ s/\[/\\\[/g;
+ $target_string =~ s/\]/\\\]/g;
+ $target_string =~ s/\*/\\\*/g;
+ $target_string =~ s/\./\\\./g;
+ $target_string =~ s/\$/\\\$/g;
+ $target_string =~ s/\^/\\\^/g;
+ $target_string =~ s/\#/\\\#/g;
+
+ gp_message ("debug", $subr_name, "target_string on return = $target_string");
+
+ return ($target_string);
+
+} #-- End of subroutine prepend_backslashes
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub preprocess_function_files
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_;
+
+ my $outputdir = append_forward_slash ($input_string);
+ my @sort_fields = @{ $sort_fields_ref };
+
+ my $error_code;
+ my $cmd_output;
+ my $re;
+
+# TBD $outputdir .= "/";
+
+ gp_message ("debug", $subr_name, "enter subroutine");
+
+ my %metric_description = %{ $metric_description_ref };
+
+ for my $m (keys %metric_description)
+ {
+ gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}");
+ }
+
+ $re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC");
+ ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex");
+ if ($error_code != 0 )
+ {
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+
+ for my $field (@sort_fields)
+ {
+ $re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC");
+ ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex");
+ if ($error_code != 0 )
+ {
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+ }
+
+ $re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC");
+ ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex");
+ if ($error_code != 0 )
+ {
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+
+ if ($g_user_settings{"calltree"}{"current_value"} eq "on")
+ {
+ $re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC");
+ ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex");
+ if ($error_code != 0 )
+ {
+ gp_message ("abort", $subr_name, "execution terminated");
+ }
+ }
+
+ return (0);
+
+} #-- End of subroutine preprocess_function_files
+
+#-------------------------------------------------------------------------------
+# Print the help overview
+#-------------------------------------------------------------------------------
+sub print_help_info
+{
+ print
+ #-------Marker line - do not go beyond this line ------------------------------
+ "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n".
+ "\n".
+ "Process one or more experiments to generate a directory containing the\n" .
+ "index.html file that may be used to browse the experiment data.\n".
+ "\n".
+ "Options:\n".
+ "\n".
+ " --help print usage information and exit.\n".
+ " --version print the version number and exit.\n".
+ " --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" .
+ " messages about the processing of the data; default\n" .
+ " is off.\n".
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" .
+ " to assist with troubleshooting, or further\n" .
+ " development of this tool; on gives a modest amount\n" .
+ " of information; s, m, l, or xl gives an increasing\n" .
+ " amount of information and off disables the printing\n" .
+ " of debug information; note that currently on, s, m,\n" .
+ " and l are equivalent; this is expected to change in\n" .
+ " future updates; default is off.\n" .
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -hp, ----highlight-percentage <value> a percentage value in the interval\n" .
+ " [0,100] to select and color code source\n" .
+ " lines as well as instructions that are\n" .
+ " within this percentage of the maximum\n" .
+ " metric value(s); a value of zero (-hp 0)\n" .
+ " disables this feature; the default is 90.\n".
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -o, --output <dir-name> use <dir-name> to store the results in; the\n" .
+ " default name is ./display.<n>.html with <n> the\n" .
+ " first positive integer number not in use; an\n" .
+ " existing directory is not overwritten.\n".
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" .
+ " overwrite any existing directory with the\n" .
+ " same name; make sure that umask is set to the\n" .
+ " correct access permissions.\n" .
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" .
+ " verbose messages; if set to on, the settings for\n" .
+ " verbose, warnings and debug are ignored; default\n" .
+ " is off.\n".
+ #-------Marker line - do not go beyond this line ------------------------------
+ " -w, --warnings {on|off} enable/disable run time warning messages;\n" .
+ " default is on.\n".
+ "\n".
+# Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n".
+# Temmporarily disabled " this is an integer number; set to 0 to process all\n".
+# Temmporarily disabled " functions; the default value is 100.\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n".
+# Temmporarily disabled " from the bottom of the first page; default is off.\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n".
+# Temmporarily disabled " inclusion of functions for each metric will take\n".
+# Temmporarily disabled " place in sort order until the percentage has been\n".
+# Temmporarily disabled " reached.\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n".
+# Temmporarily disabled " and use a default set of metrics; the default is off.\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled "Environment:\n".
+# Temmporarily disabled "\n".
+# Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n".
+# Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n".
+# Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n".
+# Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n".
+# Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n".
+# Temmporarily disabled "\n".
+ "Documentation:\n".
+ "\n".
+ "A getting started guide for gprofng is maintained as a Texinfo manual.\n" .
+ "If the info and gprofng programs are properly installed at your site,\n" .
+ "the command \"info gprofng\" should give you access to this document.\n".
+ "\n".
+ "See also:\n".
+ "\n".
+ "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " .
+ "gp-display-text(1)\n";
+
+ return (0);
+
+} #-- End of subroutine print_help_info
+
+#-------------------------------------------------------------------------------
+# Print the meta data for each experiment directory.
+#-------------------------------------------------------------------------------
+sub print_meta_data_experiments
+{
+ my $subr_name = get_my_name ();
+
+ my ($mode) = @_;
+
+ for my $exp (sort keys %g_exp_dir_meta_data)
+ {
+ for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}})
+ {
+ gp_message ($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}");
+ }
+ }
+
+ return (0);
+
+} #-- End of subroutine print_meta_data_experiments
+
+#------------------------------------------------------------------------------
+# Brute force subroutine that prints the contents of a structure with function
+# level information. This version is for a top level array structure,
+# followed by a hash.
+#------------------------------------------------------------------------------
+sub print_metric_function_array
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric, $struct_type_name, $target_structure_ref) = @_;
+
+ my @target_structure = @{$target_structure_ref};
+
+ gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
+
+ for my $fields (sort keys @target_structure)
+ {
+ for my $elems (sort keys % {$target_structure[$fields]})
+ {
+ my $msg = $struct_type_name."{$metric}[$fields]{$elems} = ";
+ $msg .= $target_structure[$fields]{$elems};
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+ }
+
+ return (0);
+
+} #-- End of subroutine print_metric_function_array
+
+#------------------------------------------------------------------------------
+# Brute force subroutine that prints the contents of a structure with function
+# level information. This version is for a top level hash structure. The
+# next level may be another hash, or an array.
+#------------------------------------------------------------------------------
+sub print_metric_function_hash
+{
+ my $subr_name = get_my_name ();
+
+ my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_;
+
+ my %target_structure = %{$target_structure_ref};
+
+ gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
+
+ for my $fields (sort keys %target_structure)
+ {
+ gp_message ("debugXL", $subr_name, "metric = $metric fields = $fields");
+ if ($sub_struct_type eq "hash_hash")
+ {
+ for my $elems (sort keys %{$target_structure{$fields}})
+ {
+ my $txt = $struct_type_name."{$metric}{$fields}{$elems} = ";
+ $txt .= $target_structure{$fields}{$elems};
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+ }
+ elsif ($sub_struct_type eq "hash_array")
+ {
+ my $values = "";
+ for my $elems (sort keys @{$target_structure{$fields}})
+ {
+ $values .= "$target_structure{$fields}[$elems] ";
+ }
+ gp_message ("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values");
+ }
+ else
+ {
+ my $msg = "sub-structure type '$sub_struct_type' is not supported";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+
+ return (0);
+
+} #-- End of subroutine print_metric_function_hash
+
+#------------------------------------------------------------------------------
+# Print the opening message.
+#------------------------------------------------------------------------------
+sub print_opening_message
+{
+ my $subr_name = get_my_name ();
+#------------------------------------------------------------------------------
+# Since the second argument is an array, we pass it in by reference. The
+# alternative is to make it the last argument.
+#------------------------------------------------------------------------------
+ my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_;
+
+ my @exp_dir_list = @{$exp_dir_list_ref};
+
+ my $msg;
+ my $no_of_dirs = scalar (@exp_dir_list);
+#------------------------------------------------------------------------------
+# Build a comma separated list with all directory names. If there is only one
+# entry, the leading comma will not be inserted.
+#------------------------------------------------------------------------------
+ my $dir_list = join (", ", @exp_dir_list);
+
+#------------------------------------------------------------------------------
+# If there are at least two entries, find the last comma and replace it by
+# " and". Note that we know there is at least one comma, so the value
+# returned by rindex () cannot be -1.
+#------------------------------------------------------------------------------
+ if ($no_of_dirs > 1)
+ {
+ my $last_comma = rindex ($dir_list, ",");
+ my $ignore_value = substr ($dir_list, $last_comma, 1, " and");
+ }
+ $msg = "start $tool_name, generating directory $outputdir from $dir_list";
+
+ gp_message ("verbose", $subr_name, $msg);
+
+ if ($time_percentage_multiplier < 1.0)
+ {
+ $msg = "Handle at least ";
+ }
+ else
+ {
+ $msg = "Handle ";
+ }
+
+ $msg .= ($time_percentage_multiplier*100.0)."% of the time";
+
+ gp_message ("verbose", $subr_name, $msg);
+
+} #-- End of subroutine print_opening_message
+
+#------------------------------------------------------------------------------
+# TBD.
+#------------------------------------------------------------------------------
+sub print_program_header
+{
+ my $subr_name = get_my_name ();
+
+ my ($mode, $tool_name, $binutils_version) = @_;
+
+ my $header_limit = 60;
+ my $dashes = "-";
+
+#------------------------------------------------------------------------------
+# Generate the dashed line
+#------------------------------------------------------------------------------
+ for (2 .. $header_limit)
+ {
+ $dashes .= "-";
+ }
+
+ gp_message ($mode, $subr_name, $dashes);
+ gp_message ($mode, $subr_name, "Tool name: $tool_name");
+ gp_message ($mode, $subr_name, "Version : $binutils_version");
+ gp_message ($mode, $subr_name, "Date : " . localtime ());
+ gp_message ($mode, $subr_name, $dashes);
+
+} #-- End of subroutine print_program_header
+
+#------------------------------------------------------------------------------
+# Print a comment string, followed by the values of the options. The list
+# with the keywords is sorted alphabetically.
+#
+# The value stored in $mode is passed on to gp_message (). The intended use
+# for this is to call this function in verbose and/or debug mode.
+#
+# The comment string is converted to uppercase.
+#
+# In case the length of the comment exceeds the length of the dashed line,
+# the comment line is allowed to stick out to the right.
+#
+# If the length of the comment is less than the dashed line, it is centered
+# relative to the # length of the dashed line.
+
+# If the length of the comment and this line do not divide, an extra space is
+# added to the left of the comment.
+#
+# For example, if the comment is 55 long, there are 5 spaces to be distributed.
+# There will be 3 spaces, followed by the comment.
+#------------------------------------------------------------------------------
+sub print_table_user_settings
+{
+ my $subr_name = get_my_name ();
+
+ my ($mode, $comment) = @_;
+
+ my $leftover;
+ my $padding;
+
+ my $keyword;
+ my $user_option;
+ my $defined;
+ my $value;
+ my $data_type;
+
+ my $HEADER_LIMIT = 60;
+ my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value");
+
+#------------------------------------------------------------------------------
+# Generate the dashed line
+#------------------------------------------------------------------------------
+ my $dashes = "-";
+ for (2 .. $HEADER_LIMIT)
+ {
+ $dashes .= "-";
+ }
+
+#------------------------------------------------------------------------------
+# Determine the padding needed to the left of the comment.
+#------------------------------------------------------------------------------
+ my $length_comment = length ($comment);
+
+ $leftover = $length_comment%2;
+
+ if ($length_comment <= ($HEADER_LIMIT-2))
+ {
+ $padding = ($HEADER_LIMIT - $length_comment + $leftover)/2;
+ }
+ else
+ {
+ $padding = 0;
+ }
+
+#------------------------------------------------------------------------------
+# Generate the first blank part of the line.
+#------------------------------------------------------------------------------
+ my $blank_line = "";
+ for (1 .. $padding)
+ {
+ $blank_line .= " ";
+ }
+
+#------------------------------------------------------------------------------
+# Add the comment line with the first letter in uppercase.
+#------------------------------------------------------------------------------
+ my $final_comment = $blank_line.ucfirst ($comment);
+
+ gp_message ($mode, $subr_name, $dashes);
+ gp_message ($mode, $subr_name, $final_comment);
+ gp_message ($mode, $subr_name, $dashes);
+ gp_message ($mode, $subr_name, $header);
+ gp_message ($mode, $subr_name, $dashes);
+
+#------------------------------------------------------------------------------
+# Print a line for each option. The list is sorted alphabetically.
+#------------------------------------------------------------------------------
+ for my $rc_keyword (sort keys %g_user_settings)
+ {
+ $keyword = $rc_keyword;
+ $user_option = $g_user_settings{$rc_keyword}{"option"};
+ $defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set");
+ $data_type = $g_user_settings{$rc_keyword}{"data_type"};
+
+ if (defined ($g_user_settings{$rc_keyword}{"current_value"}))
+ {
+ $value = $g_user_settings{$rc_keyword}{"current_value"};
+ if ($data_type eq "boolean")
+ {
+ $value = $value ? "on" : "off";
+ }
+ }
+ else
+ {
+ $value = "undefined";
+ }
+
+ my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value);
+
+ gp_message ($mode, $subr_name, $print_line);
+ }
+} #-- End of subroutine print_table_user_settings
+
+#------------------------------------------------------------------------------
+# Dump the contents of nested hash "g_user_settings". Some simple formatting
+# is applied to make it easier to distinguish the various values.
+#------------------------------------------------------------------------------
+sub print_user_settings
+{
+ my $subr_name = get_my_name ();
+
+ my ($mode, $comment) = @_;
+
+ my $keyword_value_pair;
+
+ gp_message ($mode, $subr_name, $comment);
+
+ for my $rc_keyword (keys %g_user_settings)
+ {
+ my $print_line = sprintf ("%-20s =>", $rc_keyword);
+ for my $fields (sort keys %{ $g_user_settings{$rc_keyword} })
+ {
+ if (defined ($g_user_settings{$rc_keyword}{$fields}))
+ {
+ $keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields};
+ }
+ else
+ {
+ $keyword_value_pair = $fields." = ". "undefined";
+ }
+ $print_line = join (" ", $print_line, $keyword_value_pair);
+ }
+ gp_message ($mode, $subr_name, $print_line);
+ }
+} #-- End of subroutine print_user_settings
+
+#------------------------------------------------------------------------------
+# Print the version number and license information.
+#------------------------------------------------------------------------------
+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";
+
+ return (0);
+
+} #-- End of subroutine print_version_info
+
+#------------------------------------------------------------------------------
+# Process the call tree input data and generate HTML output.
+#------------------------------------------------------------------------------
+sub process_calltree
+{
+ my $subr_name = get_my_name ();
+
+ my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref,
+ $input_string) = @_;
+
+ my @function_info = @{ $function_info_ref };
+ my %function_address_info = %{ $function_address_info_ref };
+ my %addressobjtextm = %{ $addressobjtextm_ref };
+
+ my $outputdir = append_forward_slash ($input_string);
+
+ my @call_tree_data = ();
+
+ my $LANG = $g_locale_settings{"LANG"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+
+ my $infile = $outputdir . "calltree";
+ my $outfile = $outputdir . "calltree.html";
+
+ open (CALL_TREE_IN, "<", $infile)
+ or die ("Not able to open calltree file $infile for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened file $infile for reading");
+
+ open (CALL_TREE_OUT, ">", $outfile)
+ or die ("Not able to open $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ gp_message ("debug", $subr_name, "building calltree file $outfile");
+
+#------------------------------------------------------------------------------
+# The directory name is potentially used below, but since it is a constant,
+# we get it here and only once.
+#------------------------------------------------------------------------------
+# my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,"");
+# gp_message ("debug", $subr_name, "directory_name = $directory_name");
+
+#------------------------------------------------------------------------------
+# Generate some of the structures used in the HTML output.
+#------------------------------------------------------------------------------
+ my $file_title = "Call Tree overview";
+ my $html_header = ${ create_html_header (\$file_title) };
+ my $html_home_right = ${ generate_home_link ("right") };
+
+ my $page_title = "Call Tree View";
+ my $size_text = "h2";
+ my $position_text = "center";
+ my $html_title_header = ${ generate_a_header (
+ \$page_title,
+ \$size_text,
+ \$position_text) };
+
+#-------------------------------------------------------------------------------
+# Get the acknowledgement, return to main link, and final html statements.
+#-------------------------------------------------------------------------------
+ my $html_home_left = ${ generate_home_link ("left") };
+ my $html_acknowledgement = ${ create_html_credits () };
+ my $html_end = ${ terminate_html_document () };
+
+#------------------------------------------------------------------------------
+# Read all of the file into array with the name call_tree_data.
+#------------------------------------------------------------------------------
+ chomp (@call_tree_data = <CALL_TREE_IN>);
+ close (CALL_TREE_IN);
+
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+# Process the data here and generate the HTML lines.
+#------------------------------------------------------------------------------
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Print the top part of the HTML file.
+#------------------------------------------------------------------------------
+ print CALL_TREE_OUT $html_header;
+ print CALL_TREE_OUT $html_home_right;
+ print CALL_TREE_OUT $html_title_header;
+
+#-------------------------------------------------------------------------------
+# Print the generated HTML structures here.
+#-------------------------------------------------------------------------------
+## print CALL_TREE_OUT "$_" for @whatever;
+## print CALL_TREE_OUT "<pre>\n";
+## print CALL_TREE_OUT "$_\n" for @whatever2;
+## print CALL_TREE_OUT "</pre>\n";
+
+#-------------------------------------------------------------------------------
+# Print the last part of the HTML file.
+#-------------------------------------------------------------------------------
+ print CALL_TREE_OUT $html_home_left;
+ print CALL_TREE_OUT "<br>\n";
+ print CALL_TREE_OUT $html_acknowledgement;
+ print CALL_TREE_OUT $html_end;
+
+ close (CALL_TREE_OUT);
+
+ return (0);
+
+} #-- End of subroutine process_calltree
+
+#-------------------------------------------------------------------------------
+# Process the generated experiment info file(s).
+#-------------------------------------------------------------------------------
+sub process_experiment_info
+{
+ my $subr_name = get_my_name ();
+
+ my ($experiment_data_ref) = @_;
+
+ my @exp_info;
+ my @experiment_data = @{ $experiment_data_ref };
+
+ my $exp_id;
+ my $exp_name;
+ my $exp_data_file;
+ my $input_line;
+ my $target_cmd;
+ my $hostname ;
+ my $OS;
+ my $page_size;
+ my $architecture;
+ my $start_date;
+ my $end_experiment;
+ my $data_collection_duration;
+ my $total_thread_time;
+ my $user_cpu_time;
+ my $user_cpu_percentage;
+ my $system_cpu_time;
+ my $system_cpu_percentage;
+ my $sleep_time;
+ my $sleep_percentage;
+
+#-------------------------------------------------------------------------------
+# Define the regular expressions used to capture the info.
+#-------------------------------------------------------------------------------
+# Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2'
+
+ my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\'';
+
+# Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64'
+
+ my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\'';
+
+# Experiment started Mon Aug 30 13:03:20 2021
+
+ my $start_date_regex = '\s*Experiment started\s+(.+)';
+
+# Experiment Ended: 1.812441219
+
+ my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)';
+
+# Data Collection Duration: 1.812441219
+
+ my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)';
+
+# Total Thread Time (sec.): 1.812
+
+ my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)';
+
+# User CPU: 1.685 ( 95.0%)
+
+ my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)';
+
+# System CPU: 0.088 ( 5.0%)
+
+ my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)';
+
+# Sleep: 0. ( 0. %)
+
+ my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)';
+
+#-------------------------------------------------------------------------------
+# Scan the experiment data and select the info of interest.
+#-------------------------------------------------------------------------------
+ for my $i (sort keys @experiment_data)
+ {
+ $exp_id = $experiment_data[$i]{"exp_id"};
+ $exp_name = $experiment_data[$i]{"exp_name_full"};
+ $exp_data_file = $experiment_data[$i]{"exp_data_file"};
+
+ my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file";
+ gp_message ("debug", $subr_name, $msg);
+
+ open (EXPERIMENT_INFO, "<", $exp_data_file)
+ or die ("$subr_name - unable to open file $exp_data_file for reading '$!'");
+ gp_message ("debug", $subr_name, "opened file $exp_data_file for reading");
+
+ chomp (@exp_info = <EXPERIMENT_INFO>);
+
+#-------------------------------------------------------------------------------
+# Process the info for the current experiment.
+#-------------------------------------------------------------------------------
+ for my $line (0 .. $#exp_info)
+ {
+ $input_line = $exp_info[$line];
+
+ my $msg = "exp_id = $exp_id: input_line = $input_line";
+ gp_message ("debugM", $subr_name, $msg);
+
+ if ($input_line =~ /$target_cmd_regex/)
+ {
+ $target_cmd = $2;
+ gp_message ("debugM", $subr_name, "$exp_id => $target_cmd");
+ $experiment_data[$i]{"target_cmd"} = $target_cmd;
+ }
+ elsif ($input_line =~ /$host_system_regex/)
+ {
+ $hostname = $1;
+ $OS = $2;
+ $page_size = $3;
+ $architecture = $4;
+ gp_message ("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture");
+ $experiment_data[$i]{"hostname"} = $hostname;
+ $experiment_data[$i]{"OS"} = $OS;
+ $experiment_data[$i]{"page_size"} = $page_size;
+ $experiment_data[$i]{"architecture"} = $architecture;
+ }
+ elsif ($input_line =~ /$start_date_regex/)
+ {
+ $start_date = $1;
+ gp_message ("debugM", $subr_name, "$exp_id => $start_date");
+ $experiment_data[$i]{"start_date"} = $start_date;
+ }
+ elsif ($input_line =~ /$end_experiment_regex/)
+ {
+ $end_experiment = $1;
+ gp_message ("debugM", $subr_name, "$exp_id => $end_experiment");
+ $experiment_data[$i]{"end_experiment"} = $end_experiment;
+ }
+ elsif ($input_line =~ /$data_collection_duration_regex/)
+ {
+ $data_collection_duration = $1;
+ gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration");
+ $experiment_data[$i]{"data_collection_duration"} = $data_collection_duration;
+ }
+#------------------------------------------------------------------------------
+# Start Label: Total
+# End Label: Total
+# Start Time (sec.): 0.000
+# End Time (sec.): 1.812
+# Duration (sec.): 1.812
+# Total Thread Time (sec.): 1.812
+# Average number of Threads: 1.000
+#
+# Process Times (sec.):
+# User CPU: 1.666 ( 91.9%)
+# System CPU: 0.090 ( 5.0%)
+# Trap CPU: 0. ( 0. %)
+# User Lock: 0. ( 0. %)
+# Data Page Fault: 0. ( 0. %)
+# Text Page Fault: 0. ( 0. %)
+# Kernel Page Fault: 0. ( 0. %)
+# Stopped: 0. ( 0. %)
+# Wait CPU: 0. ( 0. %)
+# Sleep: 0.056 ( 3.1%)
+#------------------------------------------------------------------------------
+ elsif ($input_line =~ /$total_thread_time_regex/)
+ {
+ $total_thread_time = $1;
+ gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time");
+ $experiment_data[$i]{"total_thread_time"} = $total_thread_time;
+ }
+ elsif ($input_line =~ /$user_cpu_regex/)
+ {
+ $user_cpu_time = $1;
+ $user_cpu_percentage = $2;
+ gp_message ("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage");
+ $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")";
+ $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage;
+ }
+ elsif ($input_line =~ /$system_cpu_regex/)
+ {
+ $system_cpu_time = $1;
+ $system_cpu_percentage = $2;
+ gp_message ("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage");
+ $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")";
+ $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage;
+ }
+ elsif ($input_line =~ /$sleep_regex/)
+ {
+ $sleep_time = $1;
+ $sleep_percentage = $2;
+ $experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")";
+ $experiment_data[$i]{"sleep_percentage"} = $sleep_percentage;
+
+ my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " .
+ "sleep_percentage = $sleep_percentage";
+ gp_message ("debugM", $subr_name, $msg);
+ }
+ }
+ }
+
+ for my $keys (0 .. $#experiment_data)
+ {
+ for my $fields (sort keys %{ $experiment_data[$keys] })
+ {
+ my $msg = "experiment_data[$keys]{$fields} = " .
+ $experiment_data[$keys]{$fields};
+ gp_message ("debugM", $subr_name, $msg);
+ }
+ }
+
+ return (\@experiment_data);
+
+} #-- End of subroutine process_experiment_info
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub process_function_files
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier,
+ $summary_metrics, $process_all_functions, $elf_loadobjects_found,
+ $outputdir, $sort_fields_ref, $function_info_ref,
+ $function_address_and_index_ref, $LINUX_vDSO_ref,
+ $metric_description_ref, $elf_arch, $base_va_executable,
+ $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
+
+ my $old_fsummary;
+ my $total_attributed_time;
+ my $current_attributed_time;
+ my $value;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_address_and_index = %{ $function_address_and_index_ref };
+ my @sort_fields = @{ $sort_fields_ref };
+ my %metric_description = %{ $metric_description_ref };
+ my %elf_rats = %{ $elf_rats_ref };
+
+#------------------------------------------------------------------------------
+# The regex section.
+#
+# TBD: Remove the part regarding clones. Legacy.
+#------------------------------------------------------------------------------
+ my $replace_quote_regex = '"/\"';
+ my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])';
+
+ my %addressobj_index = ();
+ my %function_address_info = ();
+ my $function_address_info_ref;
+
+ $outputdir = append_forward_slash ($outputdir);
+
+ my %functions_per_metric_indexes = ();
+ my $functions_per_metric_indexes_ref;
+
+ my %functions_per_metric_first_index = ();
+ my $functions_per_metric_first_index_ref;
+
+ my %routine_list = ();
+ my %handled_routines = ();
+
+#------------------------------------------------------------------------------
+# TBD: Name cleanup needed.
+#------------------------------------------------------------------------------
+
+ my $number_of_metrics;
+ my $expr_name;
+ my $routine;
+ my $tmp;
+ my $loadobj;
+ my $PCA;
+ my $address_field;
+ my $limit_txt;
+ my $n_metrics_text;
+ my $disfile;
+ my $srcfile;
+ my $RIN;
+ my $gp_listings_cmd;
+ my $gp_display_text_cmd;
+ my $ignore_value;
+
+ my $result_file = $outputdir . "gp-listings.out";
+ my $gp_error_file = $outputdir . "gp-listings.err";
+
+ my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+ my $length_of_string = length ($outputdir);
+
+ $expr_name = join (" ", @exp_dir_list);
+
+ gp_message ("debug", $subr_name, "expr_name = $expr_name");
+
+#------------------------------------------------------------------------------
+# Loop over the files in $outputdir.
+#------------------------------------------------------------------------------
+ while (glob ($outputdir.'*.sort.func-PC'))
+ {
+ my $metric;
+ my $infile;
+ my $ignore_value;
+ my $suffix_not_used;
+
+ $infile = $_;
+
+ ($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC");
+
+ gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
+ gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-");
+
+ # Function_info creates the functions files from the PC ones
+ # as well as culling PC and metric information
+
+ ($function_address_info_ref,
+ $functions_per_metric_first_index_ref,
+ $functions_per_metric_indexes_ref) = function_info (
+ $outputdir,
+ $infile,
+ $metric,
+ $LINUX_vDSO_ref);
+
+ @{$function_address_info{$metric}} = @{$function_address_info_ref};
+ %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref};
+ %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref};
+
+ $ignore_value = print_metric_function_array ($metric,
+ "function_address_info",
+ \@{$function_address_info{$metric}});
+ $ignore_value = print_metric_function_hash ("hash_hash", $metric,
+ "functions_per_metric_first_index",
+ \%{$functions_per_metric_first_index{$metric}});
+ $ignore_value = print_metric_function_hash ("hash_array", $metric,
+ "functions_per_metric_indexes",
+ \%{$functions_per_metric_indexes{$metric}});
+ }
+
+#------------------------------------------------------------------------------
+# Get header info for use in post processing er_html output
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "get_hdr_info section");
+
+ get_hdr_info ($outputdir, $outputdir."functions.sort.func");
+
+ for my $field (@sort_fields)
+ {
+ get_hdr_info ($outputdir, $outputdir."$field.sort.func");
+ }
+
+#------------------------------------------------------------------------------
+# Caller-callee
+#------------------------------------------------------------------------------
+ get_hdr_info ($outputdir, $outputdir."calls.sort.func");
+
+#------------------------------------------------------------------------------
+# Calltree
+#------------------------------------------------------------------------------
+ if ($g_user_settings{"calltree"}{"current_value"} eq "on")
+ {
+ get_hdr_info ($outputdir, $outputdir."calltree.sort.func");
+ }
+
+ gp_message ("debug", $subr_name, "process functions");
+
+ my $scriptfile = $outputdir.'gp-script';
+ my $script_metrics = "$summary_metrics";
+ my $func_limit = $g_user_settings{"func_limit"}{"current_value"};
+
+ open (SCRIPT, ">", $scriptfile)
+ or die ("Unable to create script file $scriptfile - '$!'");
+ gp_message ("debug", $subr_name, "opened script file $scriptfile for writing");
+
+ print SCRIPT "# limit $func_limit\n";
+ print SCRIPT "limit $func_limit\n";
+ print SCRIPT "# thread_select all\n";
+ print SCRIPT "thread_select all\n";
+ print SCRIPT "# metrics $script_metrics\n";
+ print SCRIPT "metrics $script_metrics\n";
+
+ for my $metric (@sort_fields)
+ {
+ gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}");
+
+ $total_attributed_time = 0;
+ $current_attributed_time = 0;
+
+ $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total>
+ if ($convert_to_dot)
+ {
+ $value =~ s/$decimal_separator/\./;
+ }
+ $total_attributed_time = $value;
+
+#------------------------------------------------------------------------------
+# start at 1 - skipping <Total>
+#------------------------------------------------------------------------------
+ for my $INDEX (1 .. $#{$function_address_info{$metric}})
+ {
+#------------------------------------------------------------------------------
+#Looking to handle at least 99% of the time - or what the user asked for
+#------------------------------------------------------------------------------
+ $value = $function_address_info{$metric}[$INDEX]{"metric_value"};
+ $routine = $function_address_info{$metric}[$INDEX]{"routine"};
+
+ gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time");
+ gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)");
+
+ if ($convert_to_dot)
+ {
+ $value =~ s/$decimal_separator/\./;
+ }
+
+ if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or
+ ( ($total_attributed_time == 0) and ($value>0) ) or
+ $process_all_functions)
+ {
+ $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"};
+
+ if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and
+ exists ($function_address_and_index{$routine}{$PCA}))
+ {
+#------------------------------------------------------------------------------
+# handled_routines now contains $RI from "first_metric" (?)
+#------------------------------------------------------------------------------
+ $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1;
+ my $description = ${ retrieve_metric_description (\$metric, \%metric_description) };
+ if ($metric_description{$metric} =~ /Exclusive Total CPU Time/)
+ {
+ $routine_list{$routine} = 1
+ }
+
+ gp_message ("debugXL", $subr_name, " $routine is candidate");
+ }
+ else
+ {
+ die ("internal error for metric $metric and routine $routine");
+ }
+
+ $current_attributed_time += $value;
+ }
+ }
+ }
+#------------------------------------------------------------------------------
+# Sort numerically in ascending order.
+#------------------------------------------------------------------------------
+ for my $routine_index (sort {$a <=> $b} keys %handled_routines)
+ {
+ $routine = $function_info[$routine_index]{"routine"};
+ gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine");
+ next unless $routine_list{$routine};
+
+# not used $source = $function_info[$routine_index]{"Source File"};
+
+ $function_info[$routine_index]{"srcline"} = "";
+ $address_field = $function_info[$routine_index]{"addressobjtext"};
+
+## $disfile = "file\.$routine_index\.dis";
+ $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"};
+ $srcfile = "";
+ $srcfile = "file\.$routine_index\.src.txt";
+
+#------------------------------------------------------------------------------
+# If the file is unknown, we can disassemble anyway and add disassembly
+# to the script.
+#------------------------------------------------------------------------------
+ print SCRIPT "# outfile $outputdir"."$disfile\n";
+ print SCRIPT "outfile $outputdir"."$disfile\n";
+#------------------------------------------------------------------------------
+# TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope.
+#------------------------------------------------------------------------------
+ $tmp = $routine;
+ $tmp =~ s/$replace_quote_regex//g;
+ print SCRIPT "# disasm \"$tmp\" $address_field\n";
+ print SCRIPT "disasm \"$tmp\" $address_field\n";
+ if ($srcfile=~/file/)
+ {
+ print SCRIPT "# outfile $outputdir"."$srcfile\n";
+ print SCRIPT "outfile $outputdir"."$srcfile\n";
+ print SCRIPT "# source \"$tmp\" $address_field\n";
+ print SCRIPT "source \"$tmp\" $address_field\n";
+ }
+
+ if ($routine =~ /$find_clone_regex/)
+ {
+ my ($clone_routine) = $1.$2.$3.$4;
+ my ($clone) = $3;
+ }
+ }
+ close SCRIPT;
+
+#------------------------------------------------------------------------------
+# Remember the number of handled routines depends on the limit setting passed
+# to er_print together with the sorting order on the metrics, which usually results
+# in different routines at the top. Thus $RIN below can be greater than the limit.
+#------------------------------------------------------------------------------
+
+ $RIN = scalar (keys %handled_routines);
+
+ if (!$func_limit)
+ {
+ $limit_txt = "unlimited";
+ }
+ else
+ {
+ $limit_txt = $func_limit - 1;
+ }
+
+ $number_of_metrics = scalar (@sort_fields);
+
+ $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics";
+
+ gp_message ("debugXL", $subr_name, "built function list with $RIN functions");
+ gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt");
+
+# add ELF program header offset
+
+ for my $routine_index (sort {$a <=> $b} keys %handled_routines)
+ {
+ $routine = $function_info[$routine_index]{"routine"};
+ $loadobj = $function_info[$routine_index]{"Load Object"};
+
+ gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch");
+
+ if ($loadobj ne '')
+ {
+ # <Truncated-stack> is associated with <Total>. Its load object is <Total>
+ if ($loadobj eq "<Total>")
+ {
+ next;
+ }
+ # Have seen a routine called <Unknown>. Its load object is <Unknown>
+ if ($loadobj eq "<Unknown>")
+ {
+ next;
+ }
+###############################################################################
+## RUUD: The new approach gives a different result. Investigate this.
+#
+# Turns out the new code improves the result. The addresses are now correct
+# and as a result, more ftag's are created later on.
+###############################################################################
+ gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
+
+ $function_info[$routine_index]{"addressobj"} += hex (
+ determine_base_va_address (
+ $executable_name,
+ $base_va_executable,
+ $loadobj,
+ $routine));
+ $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index;
+
+ gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
+ gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Get the disassembly and source code output.
+#------------------------------------------------------------------------------
+ $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " .
+ "-compare off -script $scriptfile $expr_name";
+
+ $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file";
+
+ gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd");
+
+ gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output");
+
+ my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
+
+ if ($error_code != 0)
+ {
+ $ignore_value = msg_display_text_failure ($gp_display_text_cmd,
+ $error_code,
+ $gp_error_file);
+ gp_message ("abort", "execution terminated");
+ }
+
+ return (\@function_info, \%function_address_info, \%addressobj_index);
+
+} #-- End of subroutine process_function_files
+
+#------------------------------------------------------------------------------
+# Process the information found in the function overview file passed in.
+#
+# Example input:
+#
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Functions sorted by metric: Exclusive Total CPU Time
+#
+# PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl.
+# Total Cycles Instructions Last-Level IPC CPI
+# CPU sec. sec. Executed Cache Misses
+# 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634
+# 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651
+# 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000
+#------------------------------------------------------------------------------
+sub process_function_overview
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref,
+ $function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_;
+
+ my $metric = ${ $metric_ref };
+ my $exp_type = ${ $exp_type_ref };
+ my $summary_metrics = ${ $summary_metrics_ref };
+ my $number_of_metrics = ${ $number_of_metrics_ref };
+ my @function_info = @{ $function_info_ref };
+ my %function_view_structure = %{ $function_view_structure_ref };
+ my $overview_file = ${ $overview_file_ref };
+
+ my $all_metrics;
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+ my $length_of_block;
+ my $elements_in_name;
+ my $full_hex_address;
+ my $header_line;
+ my $hex_address;
+ my $html_line;
+ my $input_line;
+ my $name_regex;
+ my $no_of_fields;
+ my $metrics_length;
+ my $missing_digits;
+ my $remaining_part_header;
+ my $routine;
+ my $routine_length;
+ my $scan_header = $FALSE;
+ my $scan_function_data = $FALSE;
+ my $string_length;
+ my $total_header_lines;
+
+ my @address_field = ();
+ my @fields = ();
+ my @function_data = ();
+ my @function_names = ();
+ my @function_view_array = ();
+ my @function_view_modified = ();
+ my @header_lines = ();
+ my @metrics_part = ();
+ my @metric_values = ();
+
+#------------------------------------------------------------------------------
+# The regex section.
+#------------------------------------------------------------------------------
+ my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
+ my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)';
+ my $empty_line_regex = '^\s*$';
+ my $catch_all_regex = '\s*(.*)';
+ my $get_hex_address_regex = '(\d+):0x(\S+)';
+ my $get_addr_offset_regex = '^@\d+:';
+ my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)';
+ my $backward_slash_regex = '\/';
+
+#------------------------------------------------------------------------------
+ if (is_file_empty ($overview_file))
+ {
+ gp_message ("error", $subr_name, "assertion error: file $overview_file is empty");
+ }
+
+ open (FUNC_OVERVIEW, "<", $overview_file)
+ or die ("$subr_name - unable to open file $overview_file for reading '$!'");
+ gp_message ("debug", $subr_name, "opened file $overview_file for reading");
+
+ gp_message ("debug", $subr_name, "processing file for exp_type = $exp_type");
+
+ gp_message ("debugM", $subr_name, "header_name_regex = $header_name_regex");
+ gp_message ("debugM", $subr_name, "total_marker_regex = $total_marker_regex");
+ gp_message ("debugM", $subr_name, "empty_line_regex = $empty_line_regex");
+ gp_message ("debugM", $subr_name, "catch_all_regex = $catch_all_regex");
+ gp_message ("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex");
+ gp_message ("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex");
+ gp_message ("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex");
+ gp_message ("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex");
+
+#------------------------------------------------------------------------------
+# Read the input file into memory.
+#------------------------------------------------------------------------------
+ chomp (@function_data = <FUNC_OVERVIEW>);
+ gp_message ("debug", $subr_name, "read all of file $overview_file into memory");
+
+#-------------------------------------------------------------------------------
+# Parse the function view info and store the data.
+#-------------------------------------------------------------------------------
+ my $max_header_length = 0;
+ my $max_metrics_length = 0;
+
+#------------------------------------------------------------------------------
+# Loop over all the lines. Extract the header, metric values, function names,
+# and the addresses.
+#
+# This is also where the maximum lengths for the header and metric lines are
+# computed. This is used to get the correct alignment in the HTML output.
+#------------------------------------------------------------------------------
+ for (my $line = 0; $line <= $#function_data; $line++)
+ {
+ $input_line = $function_data[$line];
+ gp_message ("debugXL", $subr_name, "input_line = $input_line");
+
+#------------------------------------------------------------------------------
+# The table header is assumed to start at the line that has "Name" in it.
+# The header ends when we see the function name "<Total>".
+#------------------------------------------------------------------------------
+ if ($input_line =~ /$header_name_regex/)
+ {
+ $scan_header = $TRUE;
+ }
+ elsif ($input_line =~ /$total_marker_regex/)
+ {
+ $scan_header = $FALSE;
+ $scan_function_data = $TRUE;
+ }
+
+ if ($scan_header)
+ {
+#------------------------------------------------------------------------------
+# This group is only defined for the first line of the header and $4 contains
+# the remaining part of the line after "Name", without the leading spaces.
+#------------------------------------------------------------------------------
+ if (defined ($4))
+ {
+ $remaining_part_header = $4;
+ my $msg = "remaining_part_header = $remaining_part_header";
+ gp_message ("debugXL", $subr_name, $msg);
+
+#------------------------------------------------------------------------------
+# Determine the maximum length of the header. This needs to be done before
+# the HTML controls are added.
+#------------------------------------------------------------------------------
+ my $header_length = length ($remaining_part_header);
+ $max_header_length = max ($max_header_length, $header_length);
+
+#------------------------------------------------------------------------------
+# TBD Should change this and not yet include html in header_lines
+#------------------------------------------------------------------------------
+ $html_line = "<b>" . $remaining_part_header . "</b>";
+
+ push (@header_lines, $html_line);
+
+ gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length");
+ gp_message ("debugXL", $subr_name, "html_line = $html_line");
+ }
+#------------------------------------------------------------------------------
+# Captures the subsequent header lines. Assume they exist.
+#------------------------------------------------------------------------------
+ elsif ($input_line =~ /$catch_all_regex/)
+ {
+ $header_line = $1;
+ gp_message ("debugXL", $subr_name, "header_line = $header_line");
+
+ my $header_length = length ($header_line);
+ $max_header_length = max ($max_header_length, $header_length);
+
+#------------------------------------------------------------------------------
+# TBD Should change this and not yet include html in header_lines
+#------------------------------------------------------------------------------
+ $html_line = "<b>" . $header_line . "</b>";
+
+ push (@header_lines, $html_line);
+
+ gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length");
+ gp_message ("debugXL", $subr_name, "html_line = $html_line");
+ }
+ }
+#------------------------------------------------------------------------------
+# This is a line with function data.
+#------------------------------------------------------------------------------
+ if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/)))
+ {
+ @fields = split (" ", $input_line);
+
+ $no_of_fields = $#fields + 1;
+ $elements_in_name = $no_of_fields - $number_of_metrics - 1;
+
+ gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name");
+
+#------------------------------------------------------------------------------
+# TBD: Handle this better in case a function entry has more than 2 words.
+# Build the regex dynamically and use eval to capture the correct group.
+# CHECK CODE IN GENERATE_CALLER_CALLEE
+#------------------------------------------------------------------------------
+ if ($elements_in_name == 1)
+ {
+ $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)';
+ }
+ elsif ($elements_in_name == 2)
+ {
+ $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)';
+ }
+ else
+ {
+ gp_message ("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit");
+ }
+
+ if ($input_line =~ /$name_regex/)
+ {
+ $full_hex_address = $1;
+ $routine = $2;
+
+ if ($elements_in_name == 1)
+ {
+ $all_metrics = $3;
+ }
+ elsif ($elements_in_name == 2)
+ {
+ $all_metrics = $5;
+ }
+
+#------------------------------------------------------------------------------
+# In case the last metric is 0. only, we append 3 extra characters that
+# represent zero. We cannot change the number to 0.000 though because that
+# has a different interpretation than 0.
+# In a later phase, the "ZZZ" symbol will be removed again, but for now it
+# creates consistency in, for example, the length of the metrics part.
+#------------------------------------------------------------------------------
+ if ($all_metrics =~ /$zero_dot_at_end_regex/)
+ {
+ if (defined ($1) )
+ {
+#------------------------------------------------------------------------------
+# Somewhat overkill, but remove the leading "\" from the decimal separator
+# in the debug print since it is used for internal purposes only.
+#------------------------------------------------------------------------------
+ my $decimal_point = $decimal_separator;
+ $decimal_point =~ s/$backward_slash_regex//;
+ my $txt = "all_metrics = $all_metrics ended with 0";
+ $txt .= "$decimal_point ($decimal_separator)";
+ gp_message ("debugXL", $subr_name, $txt);
+
+ $all_metrics .= "ZZZ";
+ }
+ }
+ $metrics_length = length ($all_metrics);
+ $max_metrics_length = max ($max_metrics_length, $metrics_length);
+ gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length");
+
+ if ($full_hex_address =~ /$get_hex_address_regex/)
+ {
+ $hex_address = "0x" . $2;
+ }
+
+ push (@address_field, $hex_address);
+ push (@metric_values, $all_metrics);
+
+#------------------------------------------------------------------------------
+# Record the function name "as is". Below we figure out what the final name
+# should be in case there are multiple occurrences of the same name.
+#
+# The reason to decouple this is to avoid the code gets too complex here.
+#------------------------------------------------------------------------------
+ push (@function_names, $routine);
+ }
+ }
+ } #-- End of loop over the input lines
+
+#------------------------------------------------------------------------------
+# Store the maximum lengths for the header and metrics.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length");
+ gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length");
+
+ $function_view_structure{"max header length"} = $max_header_length;
+ $function_view_structure{"max metrics length"} = $max_metrics_length;
+
+#------------------------------------------------------------------------------
+# Determine the final name for the functions and set up the HTML block.
+#------------------------------------------------------------------------------
+ my @final_html_function_block = ();
+ my @function_index_list = ();
+
+#------------------------------------------------------------------------------
+# First, an index list is built. If we are to index the functions in order of
+# appearance in the function overview from 0 to n-1, the value of the array
+# for index "i" is the index into the large "function_info" structure. This
+# has the final name, the html function block, etc.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+## TBD: Use get_index_function_info??!!
+#------------------------------------------------------------------------------
+ for my $i (keys @function_names)
+ {
+#------------------------------------------------------------------------------
+# Get the function name and the address from the function overview. The
+# address is used to differentiate in case a function has multiple occurences.
+#------------------------------------------------------------------------------
+ my $routine = $function_names[$i];
+ my $current_address = $address_field[$i];
+
+ my $found_a_match = $FALSE;
+ my $final_function_name;
+ my $ref_index;
+
+#------------------------------------------------------------------------------
+# Check if there are duplicate entries for this function. If there are, use
+# the address to find the right match in the function_info structure.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences");
+ if (exists ($g_multi_count_function{$routine}))
+ {
+ gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
+ for my $ref (keys @{ $g_map_function_to_index{$routine} })
+ {
+ my $ref_index = $g_map_function_to_index{$routine}[$ref];
+ my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
+#------------------------------------------------------------------------------
+# The address has the following format: 6:0x0003af50, but we only need the
+# part after the colon and remove the first part.
+#------------------------------------------------------------------------------
+ $addr_offset =~ s/$get_addr_offset_regex//;
+
+ gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index");
+ gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
+ gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
+
+ if ($addr_offset eq $current_address)
+#------------------------------------------------------------------------------
+# There is a match and we can store the index.
+#------------------------------------------------------------------------------
+ {
+ $found_a_match = $TRUE;
+ push (@function_index_list, $ref_index);
+ last;
+ }
+ }
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# This is the easy case. There is only one index value. We do check if the
+# array element that contains it, exists. If this is not the case, something
+# has gone horribly wrong earlier and we need to bail out.
+#------------------------------------------------------------------------------
+ if (defined ($g_map_function_to_index{$routine}[0]))
+ {
+ $found_a_match = $TRUE;
+ $ref_index = $g_map_function_to_index{$routine}[0];
+ push (@function_index_list, $ref_index);
+ my $final_function_name = $function_info[$ref_index]{"routine"};
+ gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name");
+ }
+ }
+ if (not $found_a_match)
+#------------------------------------------------------------------------------
+# This should not happen. All we can do is print an error message and stop.
+#------------------------------------------------------------------------------
+ {
+ my $msg = "cannot find the index for $routine: found_a_match = ";
+ $msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+
+#------------------------------------------------------------------------------
+# The loop over all function names has completed and @function_index_list
+# contains the index values into @function_info for the functions.
+#
+# All we now need to do is to retrieve the correct field(s) from the array.
+#------------------------------------------------------------------------------
+ for my $i (keys @function_index_list)
+ {
+ my $index_for_function = $function_index_list[$i];
+ push (@final_html_function_block, $function_info[$index_for_function]{"html function block"});
+ }
+ for my $i (keys @final_html_function_block)
+ {
+ my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+
+#------------------------------------------------------------------------------
+# Since the numbers are right aligned, we know that any difference between the
+# metric line length and the maximum must be caused by the first column. All
+# we need to do is to prepend spaces in case of a difference.
+#
+# While we have the line with the metric values, we also replace ZZZ by 3
+# spaces.
+#------------------------------------------------------------------------------
+ for my $i (keys @metric_values)
+ {
+ if (length ($metric_values[$i]) < $max_metrics_length)
+ {
+ my $pad = $max_metrics_length - length ($metric_values[$i]);
+ my $spaces = "";
+ for my $s (1 .. $pad)
+ {
+ $spaces .= " ";
+ }
+ $metric_values[$i] = $spaces . $metric_values[$i];
+ }
+ $metric_values[$i] =~ s/ZZZ/ /g;
+ }
+
+#------------------------------------------------------------------------------
+# Determine the column widths. The start and end index of the words in the
+# input line are stored in elements 0 and 1 of @word_index_values.
+#
+# The assumption made is that the first digit of a metric value on the first
+# line is left # aligned with the header text. These are the Total values
+# and other than for some derived metrics, e.g. CPI, should be the largest.
+#
+# The positions of the start of the value is what we should then use for the
+# word "(sort)" to start.
+#
+# For example:
+#
+# Excl. Excl. CPU Excl. Excl. Excl. Excl.
+# Total Cycles Instructions Last-Level IPC CPI
+# CPU sec. sec. Executed Cache Misses
+# 174.664 179.250 175838403203 1166209617 0.428 2.339
+#------------------------------------------------------------------------------
+
+ my $foundit_ref;
+ my $foundit;
+ my @index_values = ();
+ my $index_values_ref;
+
+#------------------------------------------------------------------------------
+# Search for "Excl." in the top row. The metric values are aligned with this
+# word and we can use it to position "(sort)" in the last header line.
+#
+# In @index_values, we store the position(s) of "Excl." in the header line.
+# If none can be found, an exception is raised because at least one should
+# be there.
+#
+# TBD: Check if this can be done only once.
+# ------------------------------------------------------------------------------
+ my $target_keyword = "Excl.";
+
+ ($foundit_ref, $index_values_ref) = find_keyword_in_string (
+ \$remaining_part_header,
+ \$target_keyword);
+
+ $foundit = ${ $foundit_ref };
+ @index_values = @{ $index_values_ref };
+
+ if ($foundit)
+ {
+ for my $i (keys @index_values)
+ {
+ my $txt = "index_values[$i] = $index_values[$i]";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+ }
+ else
+ {
+ my $msg = "keyword $target_keyword not found in $remaining_part_header";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+# ------------------------------------------------------------------------------
+# Compute the number of spaces we need to add between the "(sort)" strings.
+#
+# For example:
+#
+# 01234567890123456789
+#
+# Excl. Excl.
+# (sort) (sort)
+# xxxxxxxx
+#
+# The number of spaces required is 14 - 6 = 8.
+#
+# The number of spaces to be added is stored in @padding_values. These are
+# the spaces to be added before the occurrence of "(sort)". This is why the
+# first padding value is 0.
+# ------------------------------------------------------------------------------
+
+# ------------------------------------------------------------------------------
+# TBD: This needs to be done only once.
+# ------------------------------------------------------------------------------
+ my @padding_values = ();
+ my $P_previous = 0;
+ for my $i (keys @index_values)
+ {
+ my $L = $index_values[$i];
+ my $P = $L + length ("(sort)");
+ my $pad_spaces = $L - $P_previous;
+
+ push (@padding_values, $pad_spaces);
+
+ $P_previous = $P;
+ }
+
+ for my $i (keys @padding_values)
+ {
+ my $txt = "padding_values[$i] = $padding_values[$i]";
+ gp_message ("debugXL", $subr_name, $txt);
+ }
+
+#------------------------------------------------------------------------------
+# Build up the sort line. Mark the current metric and make sure the line is
+# aligned with the header.
+#------------------------------------------------------------------------------
+ my $sort_string = "(sort)";
+ my $length_sort_string = length ($sort_string);
+ my $sort_line = "";
+ my @active_metrics = split (":", $summary_metrics);
+ for my $i (0 .. $number_of_metrics-1)
+ {
+ my $pad = $padding_values[$i];
+ my $metric_value = $active_metrics[$i];
+
+ my $spaces = "";
+ for my $s (1 .. $pad)
+ {
+ $spaces .= " ";
+ }
+
+ gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad");
+
+ if ($metric_value eq $exp_type)
+#------------------------------------------------------------------------------
+# The current metric should have a different background color.
+#------------------------------------------------------------------------------
+ {
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ "." . $metric_value . ".html' style='background-color:" .
+ $g_html_color_scheme{"background_selected_sort"} .
+ "\'><b>(sort)</b></a>";
+ }
+ elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric))
+#------------------------------------------------------------------------------
+# Set the background color for the sort metric in the main function overview.
+#------------------------------------------------------------------------------
+ {
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ "." . $metric_value . ".html' style='background-color:" .
+ $g_html_color_scheme{"background_selected_sort"} .
+ "'><b>(sort)</b></a>";
+ }
+ else
+#------------------------------------------------------------------------------
+# Do not set a specific background for all other metrics.
+#------------------------------------------------------------------------------
+ {
+ $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
+ "." . $metric_value . ".html'>(sort)</a>";
+ }
+
+#------------------------------------------------------------------------------
+# Prepend the spaces to ensure correct alignment with the rest of the header.
+#------------------------------------------------------------------------------
+ $sort_line .= $spaces . $sort_string;
+ }
+
+ push (@header_lines, $sort_line);
+
+#------------------------------------------------------------------------------
+# Print the final results for the header and metrics.
+#------------------------------------------------------------------------------
+ for my $i (keys @header_lines)
+ {
+ gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
+ }
+ for my $i (keys @metric_values)
+ {
+ gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]");
+ }
+
+#------------------------------------------------------------------------------
+# Construct the lines for the function overview.
+#
+# TBD: We could eliminate two structures here because metric_values and
+# final_html_function_block are only copied and the result stored.
+#------------------------------------------------------------------------------
+ for my $i (keys @function_names)
+ {
+ push (@metrics_part, $metric_values[$i]);
+ push (@function_view_array, $final_html_function_block[$i]);
+ }
+
+ for my $i (0 .. $#function_view_array)
+ {
+ my $msg = "function_view_array[$i] = $function_view_array[$i]";
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+#------------------------------------------------------------------------------
+# Element "function table" contains the array with all the function view data.
+#------------------------------------------------------------------------------
+ $function_view_structure{"header"} = [@header_lines];
+ $function_view_structure{"metrics part"} = [@metrics_part];
+ $function_view_structure{"function table"} = [@function_view_array];
+
+ return (\%function_view_structure);
+
+} #-- End of subroutine process_function_overview
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub process_metrics
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_;
+
+ my @sort_fields = @{ $sort_fields_ref };
+ my %metric_description = %{ $metric_description_ref };
+ my %ignored_metrics = %{ $ignored_metrics_ref };
+
+ my $outputdir = append_forward_slash ($input_string);
+ my $LANG = $g_locale_settings{"LANG"};
+ my $max_len = 0;
+ my $metric_comment;
+
+ my ($imetricn,$outfile);
+ my ($html_metrics_record,$imetric,$metric);
+
+ $html_metrics_record =
+ "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" .
+ "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
+ "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n";
+
+ $outfile = $outputdir . "metrics.html";
+
+ open (METRICSOUT, ">", $outfile)
+ or die ("$subr_name - unable to open file $outfile for writing - '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile for writing");
+
+ for $metric (@sort_fields)
+ {
+ $max_len = max ($max_len, length ($metric));
+ gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len");
+ }
+
+# TBD: Check this
+# for $imetric (@IMETRICS)
+ for $imetric (keys %ignored_metrics)
+ {
+ $max_len = max ($max_len, length ($imetric));
+ gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len");
+ }
+
+ $max_len++;
+
+ gp_message ("debug", $subr_name, "max_len = $max_len");
+
+ $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">";
+ for $metric (@sort_fields)
+ {
+ my $description = ${ retrieve_metric_description (\$metric, \%metric_description) };
+ gp_message ("debug", $subr_name, "handling metric metric = $metric->$description");
+ $html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n";
+ }
+
+# $imetricn = scalar (keys %IMETRICS);
+ $imetricn = scalar (keys %ignored_metrics);
+ if ($imetricn)
+ {
+ $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">";
+# for $imetric (sort keys %IMETRICS){
+ for $imetric (sort keys %ignored_metrics)
+ {
+ $metric_comment = "(inclusive, exclusive, and percentages)";
+ $html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n";
+ gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment");
+ }
+ }
+
+ print METRICSOUT $html_metrics_record;
+ print METRICSOUT $g_html_credits_line;
+ close (METRICSOUT);
+
+ gp_message ("debug", $subr_name, "closed metrics file $outfile");
+
+ return (0);
+
+} #-- End of subroutine process_metrics
+
+#-------------------------------------------------------------------------------
+# TBD
+#-------------------------------------------------------------------------------
+sub process_metrics_data
+{
+ my $subr_name = get_my_name ();
+
+ my ($outfile1, $outfile2, $ignored_metrics_ref) = @_;
+
+ my %ignored_metrics = %{ $ignored_metrics_ref };
+
+ my %metric_value = ();
+ my %metric_description = ();
+ my %metric_found = ();
+
+ my $user_metrics;
+ my $system_metrics;
+ my $wall_metrics;
+ my $metric_spec;
+ my $metric_flavor;
+ my $metric_visibility;
+ my $metric_name;
+ my $metric_text;
+ my $metricdata;
+ my $metric_line;
+
+ my $summary_metrics;
+ my $detail_metrics;
+ my $detail_metrics_system;
+ my $call_metrics;
+
+ if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
+ {
+ gp_message ("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"});
+ # get metrics
+
+ $summary_metrics='';
+ $detail_metrics='';
+ $detail_metrics_system='';
+ $call_metrics = '';
+ $user_metrics=0;
+ $system_metrics=0;
+ $wall_metrics=0;
+
+ my ($last_metric,$metric,$value,$i,$r);
+
+ open (METRICTOTALS, "<", $outfile2)
+ or die ("Unable to open metric value data file $outfile2 for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data");
+
+#------------------------------------------------------------------------------
+# Below an example of the file that has just been opened. The lines I marked
+# with a * has been wrapped by my for readability. This is not the case in the
+# file, but makes for a really long line.
+#
+# Also, the data comes from one PC experiment and two HWC experiments.
+#------------------------------------------------------------------------------
+# <Total>
+# Exclusive Total CPU Time: 32.473 (100.0%)
+# Inclusive Total CPU Time: 32.473 (100.0%)
+# Exclusive CPU Cycles: 23.586 (100.0%)
+# " count: 47054706905
+# Inclusive CPU Cycles: 23.586 (100.0%)
+# " count: 47054706905
+# Exclusive Instructions Executed: 54417033412 (100.0%)
+# Inclusive Instructions Executed: 54417033412 (100.0%)
+# Exclusive Last-Level Cache Misses: 252730685 (100.0%)
+# Inclusive Last-Level Cache Misses: 252730685 (100.0%)
+# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle:
+# * Exclusive Cycles Per Instruction:
+# * Inclusive Cycles Per Instruction:
+# * Size: 0
+# PC Address: 1:0x00000000
+# Source File: (unknown)
+# Object File: (unknown)
+# Load Object: <Total>
+# Mangled Name:
+# Aliases:
+#------------------------------------------------------------------------------
+
+ while (<METRICTOTALS>)
+ {
+ $metricdata = $_; chomp ($metricdata);
+ gp_message ("debug", $subr_name, "file metrictotals: $metricdata");
+
+#------------------------------------------------------------------------------
+# Ignoring whitespace, search for any line with a ":" in it, followed by
+# a number with or without a dot. So, an integer or floating-point number.
+#------------------------------------------------------------------------------
+ if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/)
+ {
+ gp_message ("debug", $subr_name, " candidate => $metricdata");
+ $metric = $1;
+ $value = $2;
+ if ( ($metric eq "PC Address") or ($metric eq "Size"))
+ {
+ gp_message ("debug", $subr_name, " skipped => $metric $value");
+ next;
+ }
+ gp_message ("debug", $subr_name, " proceed => $metric $value");
+ if ($metric eq '" count')
+#------------------------------------------------------------------------------
+# Hardware counter experiments have this info. Note that this line is not the
+# first one to be encountered, so $last_metric has been defined already.
+#------------------------------------------------------------------------------
+ {
+ $metric = $last_metric." Count"; # we presume .......
+ gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric");
+ }
+ $i=index ($metricdata,":");
+ $r=rindex ($metricdata,":");
+ gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r");
+ if ($i == $r)
+ {
+ if ($value > 0) # Not interested in metrics contributing zero
+ {
+ $metric_value{$metric} = $value;
+ gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}");
+ # e.g. $metric_value{Exclusive Total Thread Time} = 302.562
+ # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484
+ }
+ }
+ else
+#------------------------------------------------------------------------------
+# TBD This code deals with an old bug and may be removed.
+#------------------------------------------------------------------------------
+ { # er_print bug - e.g.
+# Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%)
+ gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-");
+ $r=rindex ($metricdata,":",$r-1);
+ if ($r == -1)
+ { # ignore
+ gp_message ("debug", $subr_name, "metrictotals odd line ignored<-");
+ $last_metric = "foo";
+ next;
+ }
+ my ($good_part)=substr ($metricdata,$r+1);
+ if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/)
+ {
+ $metric = $1;
+ $value = $2;
+ if ($value>0) # Not interested in metrics contributing zero
+ {
+ $metric_value{$metric} = $value;
+ my $msg = "metrictotals odd line rescued '$metric'=$value";
+ gp_message ("debug", $subr_name, $msg);
+ }
+ }
+ }
+#------------------------------------------------------------------------------
+# Preserve the current metric.
+#------------------------------------------------------------------------------
+ $last_metric = $metric;
+ }
+ }
+ close (METRICTOTALS);
+ }
+
+ if (scalar (keys %metric_value) == 0)
+#------------------------------------------------------------------------------
+# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we
+# blow up later.
+#
+# TBD: See if this can be handled differently.
+#------------------------------------------------------------------------------
+ {
+ $metric_value{"Exclusive Total CPU Time"} = 0;
+ gp_message ("debug", $subr_name, "no metrics found and a stub was added");
+ }
+
+ for my $metric (sort keys %metric_value)
+ {
+ gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}");
+ }
+
+ gp_message ("debug", $subr_name, "proceed to process file $outfile1");
+
+#------------------------------------------------------------------------------
+# Open and process the metrics file.
+#------------------------------------------------------------------------------
+ open (METRICS, "<", $outfile1)
+ or die ("Unable to open metrics file $outfile1: '$!'");
+ gp_message ("debug", $subr_name, "opened file $outfile1 for reading");
+
+#------------------------------------------------------------------------------
+# Parse the file. This is a typical example:
+#
+# Exp Sel Total
+# === === =====
+# 1 all 2
+# 2 all 1
+# 3 all 2
+# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
+# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
+# Available metrics:
+# Exclusive Total CPU Time: e.%totalcpu
+# Inclusive Total CPU Time: i.%totalcpu
+# Exclusive CPU Cycles: e.+%cycles
+# Inclusive CPU Cycles: i.+%cycles
+# Exclusive Instructions Executed: e+%insts
+# Inclusive Instructions Executed: i+%insts
+# Exclusive Last-Level Cache Misses: e+%llm
+# Inclusive Last-Level Cache Misses: i+%llm
+# Exclusive Instructions Per Cycle: e+IPC
+# Inclusive Instructions Per Cycle: i+IPC
+# Exclusive Cycles Per Instruction: e+CPI
+# Inclusive Cycles Per Instruction: i+CPI
+# Size: size
+# PC Address: address
+# Name: name
+#------------------------------------------------------------------------------
+ while (<METRICS>)
+ {
+ $metric_line = $_;
+ chomp ($metric_line);
+
+ gp_message ("debug", $subr_name, "processing line $metric_line");
+#------------------------------------------------------------------------------
+# The original regex has bugs because the line should not be allowed to start
+# with a ":". So this is wrong:
+# if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
+#
+# This is better:
+# if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
+#
+# In general, this regex has some potential issues and has been replaced by
+# the one shown below.
+#
+# We select a line that does not start with "Current" and aside from whitespace
+# starts with anything (although it should be a string with words only),
+# followed by whitespace and either an "e" or "i". This is called the "flavor"
+# and is followed by a visibility marker (.,+,%, or !) and a metric name.
+#------------------------------------------------------------------------------
+# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
+
+ ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) =
+ extract_metric_specifics ($metric_line);
+
+# if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
+ if ($metric_spec eq "skipped")
+ {
+ gp_message ("debug", $subr_name, "skipped line: $metric_line");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "line of interest: $metric_line");
+
+ $metric_found{$metric_spec} = 1;
+
+ if ($g_user_settings{"ignore_metrics"}{"defined"})
+ {
+ gp_message ("debug", $subr_name, "check for $metric_spec");
+ if (exists ($ignored_metrics{$metric_name}))
+ {
+ gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name");
+ next;
+ }
+ }
+
+#------------------------------------------------------------------------------
+# This metric is not on the ignored list and qualifies, so store it.
+#------------------------------------------------------------------------------
+ $metric_description{$metric_spec} = $metric_text;
+
+# TBD: add for other visibilities too, like +
+ gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}");
+
+ if ($metric_flavor ne "e")
+ {
+ gp_message ("debug", $subr_name, "metric $metric_spec is ignored");
+ }
+ else
+#------------------------------------------------------------------------------
+# Only the exclusive metrics are shown.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered");
+
+ if ($metric_spec =~ /user/)
+ {
+ $user_metrics = $TRUE;
+ gp_message ("debug", $subr_name, "m: user_metrics set to TRUE");
+ }
+ elsif ($metric_spec =~ /system/)
+ {
+ $system_metrics = $TRUE;
+ gp_message ("debug", $subr_name, "m: system_metrics set to TRUE");
+ }
+ elsif ($metric_spec =~ /wall/)
+ {
+ $wall_metrics = $TRUE;
+ gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE");
+ }
+#------------------------------------------------------------------------------
+# TBD I don't see why these need to be skipped. Also, should be totalcpu.
+#------------------------------------------------------------------------------
+ elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/))
+ {
+ # skip total thread time and total CPU time
+ gp_message ("debug", $subr_name, "m: skip above");
+ }
+ elsif (defined ($metric_value{$metric_text}))
+ {
+ gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}");
+ if ($summary_metrics ne '')
+ {
+ $summary_metrics = $summary_metrics.':'.$metric_spec;
+ gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1");
+ if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
+ {
+ $detail_metrics = $detail_metrics.':'.$metric_spec;
+ gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1");
+ $detail_metrics_system = $detail_metrics_system.':'.$metric_spec;
+ gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
+ }
+ }
+ else
+ {
+ $summary_metrics = $metric_spec;
+ gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2");
+ if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
+ {
+ $detail_metrics = $metric_spec;
+ gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2");
+ $detail_metrics_system = $metric_spec;
+ gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
+ }
+ }
+ gp_message ("debug", $subr_name, " metric $metric_spec added");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "m: no want above metric was a 0 total");
+ }
+ }
+ }
+ }
+
+ close METRICS;
+
+ if ($wall_metrics > 0)
+ {
+ gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics");
+ $summary_metrics = "e.wall:".$summary_metrics;
+ gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3");
+ }
+
+ if ($system_metrics > 0)
+ {
+ gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system");
+ $summary_metrics = "e.system:".$summary_metrics;
+ $call_metrics = "i.system:".$call_metrics;
+ $detail_metrics_system ='e.system:'.$detail_metrics_system;
+
+ gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4");
+ gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics");
+ gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3");
+ }
+
+
+#------------------------------------------------------------------------------
+# TBD: e.user and i.user do not always exist!!
+#------------------------------------------------------------------------------
+
+ if ($user_metrics > 0)
+ {
+ gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics");
+# Ruud if (!exists ($IMETRICS{"i.user"})){
+ if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
+ {
+ $summary_metrics = "e.user:".$summary_metrics;
+ }
+ else
+ {
+ $summary_metrics = "e.user:i.user:".$summary_metrics;
+ }
+ $detail_metrics = "e.user:".$detail_metrics;
+ $detail_metrics_system = "e.user:".$detail_metrics_system;
+
+ gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5");
+ gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3");
+ gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4");
+
+ if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
+ {
+ $call_metrics = "a.user:".$call_metrics;
+ }
+ else
+ {
+ $call_metrics = "a.user:i.user:".$call_metrics;
+ }
+ gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2");
+ }
+
+ if ($call_metrics eq "")
+ {
+ $call_metrics = $detail_metrics;
+
+ gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics ");
+ gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3");
+ }
+
+ for my $metric (sort keys %ignored_metrics)
+ {
+ if ($ignored_metrics{$metric})
+ {
+ gp_message ("debug", $subr_name, "active metric, but ignored: $metric");
+ }
+
+ }
+
+ return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics,
+ $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
+
+} #-- End of subroutine process_metrics_data
+
+#------------------------------------------------------------------------------
+# Process source lines that are not part of the target function.
+#
+# Generate straightforward HTML, but define an anchor based on the source line
+# number in the list.
+#------------------------------------------------------------------------------
+sub process_non_target_source
+{
+ my $subr_name = get_my_name ();
+
+ my ($start_scan, $end_scan,
+ $src_times_regex, $function_regex, $number_of_metrics,
+ $file_contents_ref, $modified_html_ref) = @_;
+
+ my @file_contents = @{ $file_contents_ref };
+ my @modified_html = @{ $modified_html_ref };
+ my $colour_code_line = $FALSE;
+ my $input_line;
+ my $line_id;
+ my $modified_line;
+
+#------------------------------------------------------------------------------
+# Main loop to parse all of the source code and take action as needed.
+#------------------------------------------------------------------------------
+ for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++)
+ {
+ $input_line = $file_contents[$line_no];
+
+#------------------------------------------------------------------------------
+# Generate straightforward HTML, but define an anchor based on the source line
+# number in the list.
+#------------------------------------------------------------------------------
+ $line_id = extract_source_line_number ($src_times_regex,
+ $function_regex,
+ $number_of_metrics,
+ $input_line);
+
+ if ($input_line =~ /$function_regex/)
+ {
+ $colour_code_line = $TRUE;
+ }
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+#------------------------------------------------------------------------------
+# Add an id.
+#------------------------------------------------------------------------------
+ $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
+
+ my $coloured_line;
+ if ($colour_code_line)
+ {
+ my $boldface = $TRUE;
+ $coloured_line = color_string (
+ $input_line,
+ $boldface,
+ $g_html_color_scheme{"non_target_function_name"});
+ $colour_code_line = $FALSE;
+ $modified_line .= "$coloured_line";
+ }
+ else
+ {
+ $modified_line .= "$input_line";
+ }
+ gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line");
+ push (@modified_html, $modified_line);
+ }
+
+ return (\@modified_html);
+
+} #-- End of subroutine process_non_target_source
+
+#------------------------------------------------------------------------------
+# This function scans the configuration file and adapts the internal settings
+# accordingly.
+#
+# Errors are stored during the parsing and processing phase. They are printed
+# at the end and sorted by line number.
+#------------------------------------------------------------------------------
+sub process_rc_file
+{
+ my $subr_name = get_my_name ();
+
+ my ($rc_file_name, $rc_file_paths_ref) = @_;
+
+#------------------------------------------------------------------------------
+# Local structures.
+#------------------------------------------------------------------------------
+ my %rc_settings_user = (); #-- Store the values extracted from the config file
+ my %error_and_warning_msgs = ();
+ my @rc_file_paths = ();
+
+ my @split_line;
+ my @my_fields;
+
+ my $message;
+ my $first_part;
+ my $line;
+ my $line_number;
+ my $number_of_fields;
+ my $number_of_paths;
+ my $parse_errors; #-- Count the number of errors
+ my $parse_warnings; #-- Count the number of errors
+
+ my $rc_config_file;
+ my $rc_file_found;
+ my $rc_keyword;
+ my $rc_value;
+
+ @rc_file_paths = @{$rc_file_paths_ref};
+ $number_of_paths = scalar (@rc_file_paths);
+
+ if ($number_of_paths == 0)
+#------------------------------------------------------------------------------
+# This should not happen, but is a good safety net to add.
+#------------------------------------------------------------------------------
+ {
+ my $msg = "search path list is empty";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Check for the presence of a configuration file.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths");
+
+ $rc_file_found = $FALSE;
+ for my $path_name (@rc_file_paths)
+ {
+ $rc_config_file = $path_name . "/" . $rc_file_name;
+ gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file");
+ if (-f $rc_config_file)
+ {
+ gp_message ("debug", $subr_name, "found configuration file $rc_config_file");
+ $rc_file_found = $TRUE;
+ last;
+ }
+ }
+
+ if (not $rc_file_found)
+#------------------------------------------------------------------------------
+# There is no configuration file and we can skip this subroutine.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found");
+ return (0);
+ }
+ else
+ {
+ open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file")
+ or die ("$subr_name - unable to open file $rc_config_file for reading: $!");
+#------------------------------------------------------------------------------
+# The configuration file has been opened for reading.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading");
+ }
+
+ gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file");
+ gp_message ("debug", $subr_name, "processing configuration file $rc_config_file");
+
+#------------------------------------------------------------------------------
+# Here we scan the configuration file for the settings.
+#
+# A setting consists of a keyword, optionally followed by a value. It is
+# optional because not all keywords may require a value.
+#
+# At the end of this block, all keyword/value pairs are stored in a hash.
+#
+# We do not yet check for the validity of these pairs. This is done next.
+#
+# The original code had this all integrated, but it made the code very
+# complex with deeply nested if-statements. The flow was also hard to follow.
+#------------------------------------------------------------------------------
+ $parse_errors = 0;
+ $parse_warnings = 0;
+ $line_number = 0;
+ while (my $line = <GP_DISPLAY_HTML_RC>)
+ {
+ chomp ($line);
+ $line_number++;
+
+ gp_message ("debug", $subr_name, "read input line = $line");
+
+#------------------------------------------------------------------------------
+# Ignore a line with whitespace only
+#------------------------------------------------------------------------------
+ if ($line =~ /^\s*$/)
+ {
+ gp_message ("debug", $subr_name, "ignored a line with whitespace");
+ next;
+ }
+
+#------------------------------------------------------------------------------
+# Ignore a comment line, defined by starting with a "#", possibly prepended by
+# whitespace.
+#------------------------------------------------------------------------------
+ if ($line =~ /^\s*\#/)
+ {
+ gp_message ("debug", $subr_name, "ignored a full comment line");
+ next;
+ }
+
+#------------------------------------------------------------------------------
+# Split the input line using the "#" symbol as a separator. We have already
+# handled the case of an isolated comment line, so there may only be an
+# embedded comment.
+#
+# Regardless of this, we are only interested in the first part.
+#------------------------------------------------------------------------------
+ @split_line = split ("#", $line);
+
+ for my $i (@split_line)
+ {
+ gp_message ("debug", $subr_name, "elements after split of line: $i");
+ }
+
+ $first_part = $split_line[0];
+ gp_message ("debug", $subr_name, "relevant part = $first_part");
+
+ if ($first_part =~ /[&\^\*\@\$]+/)
+#------------------------------------------------------------------------------
+# The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error
+# an fetch the next line.
+#------------------------------------------------------------------------------
+ {
+ $parse_errors++;
+ $message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ next;
+ }
+ else
+#------------------------------------------------------------------------------
+# Split the first part on whitespace and verify the number of fields to be
+# valid. Although we currently only have keywords with a value, a keyword
+# without value is supported to.
+#
+# If the number of fields is valid, the keyword and value are stored. In case
+# of a single field, the value is assigned a special string.
+#
+# Although this situation should not occur, we do abort if something unexpected
+# is encountered here.
+#------------------------------------------------------------------------------
+ {
+ @my_fields = split (/\s/, $split_line[0]);
+
+ $number_of_fields = scalar (@my_fields);
+ gp_message ("debug", $subr_name, "number of fields = $number_of_fields");
+ }
+
+ if ($number_of_fields ge 3)
+#------------------------------------------------------------------------------
+# This is not supported.
+#------------------------------------------------------------------------------
+ {
+ $parse_errors++;
+ $message = "more than 2 fields found: $first_part";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ next;
+ }
+ elsif ($number_of_fields eq 2)
+ {
+ $rc_keyword = $my_fields[0];
+ $rc_value = $my_fields[1];
+ }
+ elsif ($number_of_fields eq 1)
+ {
+ $rc_keyword = $my_fields[0];
+ $rc_value = "the_field_is_empty";
+ }
+ else
+ {
+ my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Store the keyword, value and line number.
+#------------------------------------------------------------------------------
+ if (exists ($rc_settings_user{$rc_keyword}))
+ {
+ $parse_warnings++;
+ my $prev_value = $rc_settings_user{$rc_keyword}{"value"};
+ my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"};
+ if ($rc_value ne $prev_value)
+ {
+ $message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'";
+ }
+ else
+ {
+ $message = "option $rc_keyword previously set to the same value at line $prev_line_number";
+ }
+ $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message;
+ }
+ $rc_settings_user{$rc_keyword}{"value"} = $rc_value;
+ $rc_settings_user{$rc_keyword}{"line_no"} = $line_number;
+
+ gp_message ("debug", $subr_name, "stored keyword = $rc_keyword");
+ gp_message ("debug", $subr_name, "stored value = $rc_value");
+ gp_message ("debug", $subr_name, "stored line number = $line_number");
+ }
+
+#------------------------------------------------------------------------------
+# Completed the parsing of the configuration file. It can be closed.
+#------------------------------------------------------------------------------
+ close (GP_DISPLAY_HTML_RC);
+
+#------------------------------------------------------------------------------
+# Print the raw input as just collected from the configuration file.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "contents of %rc_settings_user:");
+ for my $keyword (keys %rc_settings_user)
+ {
+ my $key_value = $rc_settings_user{$keyword}{"value"};
+ gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value");
+ }
+
+ for my $rc_keyword (keys %g_user_settings)
+ {
+ for my $fields (keys %{ $g_user_settings{$rc_keyword} })
+ {
+ gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
+ }
+ }
+
+#------------------------------------------------------------------------------
+# We are almost done. Check for all keywords found whether they are valid.
+# Also verify that the corresponding value is valid.
+#
+# Update the g_user_settings table if everything is okay.
+#------------------------------------------------------------------------------
+
+ for my $rc_keyword (keys %rc_settings_user)
+ {
+ my $rc_value = $rc_settings_user{$rc_keyword}{"value"};
+
+ if (exists ( $g_user_settings{$rc_keyword}))
+ {
+
+#------------------------------------------------------------------------------
+# This is a supported keyword. There are two more things left to do:
+# - Check how many values it requires (currently exactly one is supported)
+# - Is the value a valid number or string?
+#------------------------------------------------------------------------------
+ my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"};
+
+ if ($no_of_arguments eq 1)
+ {
+ my $input_value = $rc_value;
+ if ($input_value ne "the_field_is_empty")
+#
+#------------------------------------------------------------------------------
+# So far, so good. We only need to check if the value is valid for the keyword.
+#------------------------------------------------------------------------------
+ {
+ my $data_type = $g_user_settings{$rc_keyword}{"data_type"};
+ my $valid_input = verify_if_input_is_valid ($input_value, $data_type);
+#------------------------------------------------------------------------------
+# Check if the value is valid.
+#------------------------------------------------------------------------------
+ if ($valid_input)
+ {
+ $g_user_settings{$rc_keyword}{"current_value"} = $rc_value;
+ $g_user_settings{$rc_keyword}{"defined"} = $TRUE;
+ }
+ else
+ {
+ $parse_errors++;
+ $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
+ $message = "input value '$input_value' for keyword $rc_keyword is not valid";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ next;
+ }
+ }
+ else
+#------------------------------------------------------------------------------
+# This keyword requires a value, but none has been found.
+#------------------------------------------------------------------------------
+ {
+ $parse_errors++;
+ $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
+ $message = "missing value for keyword '$rc_keyword'";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ next;
+ }
+ }
+ elsif ($no_of_arguments eq 0)
+#------------------------------------------------------------------------------
+# Currently a theoretical scenario since all commands require a value, but in
+# case this is no longer true, we need to at least flag the fact the user set
+# this command.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{$rc_keyword}{"defined"} = $TRUE;
+ }
+ else
+#------------------------------------------------------------------------------
+# The code is not prepared for the situation one command has multiple values,
+# but this situation should never occur. Still it won't hurt to add a check.
+#------------------------------------------------------------------------------
+ {
+ my $msg = "cannot handle $no_of_arguments in the input";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ else
+#------------------------------------------------------------------------------
+# A non-valid keyword is found. This is flagged as an error.
+#------------------------------------------------------------------------------
+ {
+ $parse_errors++;
+ $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
+ $message = "keyword $rc_keyword is not supported";
+ $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
+ }
+ }
+ for my $rc_keyword (keys %g_user_settings)
+ {
+ for my $fields (keys %{ $g_user_settings{$rc_keyword} })
+ {
+ gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
+ }
+ }
+ print_table_user_settings ("debug", "upon the return from $subr_name");
+
+ if ( ($parse_errors == 0) and ($parse_warnings == 0) )
+ {
+ gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file");
+ }
+ else
+ {
+ if ($parse_errors > 0)
+ {
+ my $plural_or_single = ($parse_errors > 1) ? "errors" : "error";
+ $message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:";
+ gp_message ("debug", $subr_name, $message);
+#------------------------------------------------------------------------------
+# Sort the hash keys, the line numbers, alphabetically and print the
+# corresponding error messages.
+#------------------------------------------------------------------------------
+ for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} }))
+ {
+ $message = $g_error_keyword. "[line $line_no] in file $rc_config_file - ";
+ $message .= $error_and_warning_msgs{"error"}{$line_no}{"message"};
+ gp_message ("debug", $subr_name, $message);
+ }
+ }
+
+ if (not $g_quiet)
+ {
+ if ($parse_warnings > 0)
+ {
+ $message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:";
+ gp_message ("debug", $subr_name, $message);
+ for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} }))
+ {
+ $message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - ";
+ $message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"};
+ gp_message ("debug", $subr_name, $message);
+ }
+ }
+ }
+ }
+
+ return ($parse_errors);
+
+} #-- End of subroutine process_rc_file
+
+#------------------------------------------------------------------------------
+# Generate the annotated html file for the source listing.
+#------------------------------------------------------------------------------
+sub process_source
+{
+ my $subr_name = get_my_name ();
+
+ my ($number_of_metrics, $function_info_ref,
+ $outputdir, $input_filename) = @_;
+
+ my @function_info = @{ $function_info_ref };
+
+#------------------------------------------------------------------------------
+# The regex section
+#------------------------------------------------------------------------------
+ my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)';
+ my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>';
+ my $function_regex = '^(\s*)<Function:\s(.*)>';
+ my $function2_regex = '^(\s*)<Function:\s(.*)>';
+ my $src_regex = '(\s*)(\d+)\.(.*)';
+ my $txt_ext_regex = '\.txt$';
+ my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$';
+ my $integer_only_regex = '\d+';
+#------------------------------------------------------------------------------
+# Computed dynamically below.
+# TBD: Try to move this up.
+#------------------------------------------------------------------------------
+ my $src_times_regex;
+ my $hot_lines_regex;
+ my $metric_regex;
+ my $metric_extra_regex;
+
+ my @components = ();
+ my @fields_in_line = ();
+ my @file_contents = ();
+ my @hot_source_lines = ();
+ my @max_metric_values = ();
+ my @modified_html = ();
+ my @transposed_hot_lines = ();
+
+ my $colour_coded_line;
+ my $colour_coded_line_ref;
+ my $line_id;
+ my $ignore_value;
+ my $func_name_in_src_file;
+ my $html_new_line = "<br>";
+ my $input_line;
+ my $metric_values;
+ my $modified_html_ref;
+ my $modified_line;
+ my $is_empty;
+ my $start_all_source;
+ my $start_target_source;
+ my $end_target_source;
+ my $output_line;
+ my $hot_line;
+ my $src_line_no;
+ my $src_code_line;
+
+ my $decimal_separator = $g_locale_settings{"decimal_separator"};
+ my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
+
+ my $file_title;
+ my $found_target;
+ my $html_dis_record;
+ my $html_end;
+ my $html_header;
+ my $html_home;
+ my $rounded_percentage;
+ my $start_tracking;
+ my $threshold_line;
+
+ my $base;
+ my $boldface;
+ my $msg;
+ my $routine;
+
+ my $LANG = $g_locale_settings{"LANG"};
+ my $the_title = set_title ($function_info_ref, $input_filename,
+ "process source");
+ my $outfile = $input_filename . ".html";
+
+#------------------------------------------------------------------------------
+# Remove the .txt from file.<n>.src.txt
+#------------------------------------------------------------------------------
+ my $html_output_file = $input_filename;
+ $html_output_file =~ s/$txt_ext_regex/.html/;
+
+ gp_message ("debug", $subr_name, "input_filename = $input_filename");
+ gp_message ("debug", $subr_name, "the_title = $the_title");
+
+ $file_title = $the_title;
+ $html_header = ${ create_html_header (\$file_title) };
+ $html_home = ${ generate_home_link ("right") };
+
+ push (@modified_html, $html_header);
+ push (@modified_html, $html_home);
+ push (@modified_html, "<pre>");
+
+#------------------------------------------------------------------------------
+# Open the html file used for the output.
+#------------------------------------------------------------------------------
+ open (NEW_HTML, ">", $html_output_file)
+ or die ("$subr_name - unable to open file $html_output_file for writing: '$!'");
+ gp_message ("debug", $subr_name , "opened file $html_output_file for writing");
+
+ $base = get_basename ($input_filename);
+
+ gp_message ("debug", $subr_name, "base = $base");
+
+ if ($base =~ /$src_filename_id_regex/)
+ {
+ my $file_id = $1;
+ if (defined ($function_info[$file_id]{"routine"}))
+ {
+ $routine = $function_info[$file_id]{"routine"};
+
+ gp_message ("debugXL", $subr_name, "target routine = $routine");
+ }
+ else
+ {
+ my $msg = "cannot retrieve routine name for file_id = $file_id";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Check if the input file is empty. If so, generate a short text in the html
+# file and return. Otherwise open the file and read the contents.
+#------------------------------------------------------------------------------
+ $is_empty = is_file_empty ($input_filename);
+
+ if ($is_empty)
+ {
+#------------------------------------------------------------------------------
+# The input file is empty. Write a diagnostic message in the html file and exit.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name ,"file $input_filename is empty");
+
+ my $comment = "No source listing generated by $tool_name - " .
+ "file $input_filename is empty";
+ my $error_file = $outputdir . "gp-listings.err";
+
+ my $html_empty_file_ref = html_text_empty_file (\$comment, \$error_file);
+ my @html_empty_file = @{ $html_empty_file_ref };
+
+ print NEW_HTML "$_\n" for @html_empty_file;
+
+ close NEW_HTML;
+
+ return (0);
+ }
+ else
+#------------------------------------------------------------------------------
+# Open the input file with the source code
+#------------------------------------------------------------------------------
+ {
+ open (SRC_LISTING, "<", $input_filename)
+ or die ("$subr_name - unable to open file $input_filename for reading: '$!'");
+ gp_message ("debug", $subr_name, "opened file $input_filename for reading");
+ }
+
+#------------------------------------------------------------------------------
+# Generate the regex for the metrics. This depends on the number of metrics.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator<--");
+
+ $metric_regex = '';
+ $metric_extra_regex = '';
+ for my $metric_used (1 .. $number_of_metrics)
+ {
+ $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
+ }
+ $metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')';
+
+ $hot_lines_regex = '^(#{2})\s+';
+ $hot_lines_regex .= '('.$metric_regex.')';
+ $hot_lines_regex .= '([0-9?]+)\.\s+(.*)';
+
+ $src_times_regex = '^(#{2}|\s{2})\s+';
+ $src_times_regex .= '('.$metric_extra_regex.')';
+ $src_times_regex .= '(.*)';
+
+ gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex");
+ gp_message ("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex");
+ gp_message ("debugXL", $subr_name, "src_times_regex = $src_times_regex");
+ gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
+
+ gp_message ("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex");
+ gp_message ("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex");
+ gp_message ("debugXL", $subr_name, "function_regex = $function_regex");
+ gp_message ("debugXL", $subr_name, "function2_regex = $function2_regex");
+ gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
+
+#------------------------------------------------------------------------------
+# Read the file into memory.
+#------------------------------------------------------------------------------
+ chomp (@file_contents = <SRC_LISTING>);
+
+#------------------------------------------------------------------------------
+# Identify the header lines. Make the minimal assumptions.
+#
+# In both cases, the first line after the header has whitespace. This is
+# followed by either one of the following:
+#
+# - <line_no>.
+# - <Function:
+#
+# These are the characteristics we use below.
+#------------------------------------------------------------------------------
+ for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
+ {
+ $input_line = $file_contents[$line_number];
+
+#------------------------------------------------------------------------------
+# We found the first source code line. Bail out.
+#------------------------------------------------------------------------------
+ if (($input_line =~ /$end_src1_header_regex/) or
+ ($input_line =~ /$end_src2_header_regex/))
+ {
+ gp_message ("debugXL", $subr_name, "header time is over - hit source line");
+ gp_message ("debugXL", $subr_name, "line_number = $line_number");
+ gp_message ("debugXL", $subr_name, "input_line = $input_line");
+ last;
+ }
+ else
+#------------------------------------------------------------------------------
+# Store the header lines in the html structure.
+#------------------------------------------------------------------------------
+ {
+ $modified_line = "<i>" . $input_line . "</i>";
+ push (@modified_html, $modified_line);
+ }
+ }
+#------------------------------------------------------------------------------
+# We know the source code starts at this index value:
+#------------------------------------------------------------------------------
+ $start_all_source = scalar (@modified_html);
+ gp_message ("debugXL", $subr_name, "source starts at start_all_source = $start_all_source");
+
+#------------------------------------------------------------------------------
+# Scan the file to identify where the target source starts and ends.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "search for target function $routine");
+ $start_tracking = $FALSE;
+ $found_target = $FALSE;
+ for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
+ {
+ $input_line = $file_contents[$line_number];
+
+ gp_message ("debugXL", $subr_name, "[$line_number] $input_line");
+
+ if ($input_line =~ /$function_regex/)
+ {
+ if (defined ($1) and defined ($2))
+ {
+ $func_name_in_src_file = $2;
+ my $msg = "found a function - name = $func_name_in_src_file";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ if ($start_tracking)
+ {
+ $start_tracking = $FALSE;
+ $end_target_source = $line_number - 1;
+ my $msg = "end_target_source = $end_target_source";
+ gp_message ("debugXL", $subr_name, $msg);
+ last;
+ }
+
+ if ($func_name_in_src_file eq $routine)
+ {
+ $found_target = $TRUE;
+ $start_tracking = $TRUE;
+ $start_target_source = $line_number;
+
+ gp_message ("debugXL", $subr_name, "found target function $routine");
+ gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine");
+ gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
+ gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
+ }
+ }
+ else
+ {
+ my $msg = "parsing line $input_line";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ }
+
+#------------------------------------------------------------------------------
+# This is not supposed to happen, but it is not a fatal error either. The
+# hyperlinks related to this function will not work, so a warning is issued.
+# A message is issued both in debug mode, and as a warning.
+#------------------------------------------------------------------------------
+ if (not $found_target)
+ {
+ my $msg;
+ gp_message ("debug", $subr_name, "target function $routine not found");
+
+ $msg = "function $routine not found in $base - " .
+ "links to source code involving this function will not work";
+ gp_message ("warning", $subr_name, $msg);
+
+ return ($found_target);
+ }
+
+#------------------------------------------------------------------------------
+# Catch the line number of the last function.
+#------------------------------------------------------------------------------
+ if ($start_tracking)
+ {
+ $end_target_source = $#file_contents;
+ }
+ gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
+ gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
+ gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source");
+
+#------------------------------------------------------------------------------
+# We now have the index range for the function of interest and will parse it.
+# Since we already handled the first line with the function marker, we start
+# with the line following.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# Find the hot source lines and store them.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "determine the maximum metric values");
+ for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++)
+ {
+ $input_line = $file_contents[$line_number];
+ gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line");
+
+ if ( $input_line =~ /$hot_lines_regex/ )
+ {
+ gp_message ("debugXL", $subr_name, " $line_number : found a hot line");
+#------------------------------------------------------------------------------
+# We found a hot line and the metric fields are stored in $2. We turn this
+# string into an array and add it as a row to hot_source_lines.
+#------------------------------------------------------------------------------
+ $hot_line = $1;
+ $metric_values = $2;
+
+ gp_message ("debugXL", $subr_name, "hot_line = $hot_line");
+ gp_message ("debugXL", $subr_name, "metric_values = $metric_values");
+
+ my @metrics = split (" ", $metric_values);
+ push (@hot_source_lines, [@metrics]);
+ }
+ gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line");
+ }
+
+#------------------------------------------------------------------------------
+# Transpose the array with the hot lines. This means each row has all the
+# values for a metrict and it makes it easier to determine the maximum values.
+#------------------------------------------------------------------------------
+ for my $row (keys @hot_source_lines)
+ {
+ my $msg = "row[" . $row . "] = ";
+ for my $col (keys @{$hot_source_lines[$row]})
+ {
+ $msg .= "$hot_source_lines[$row][$col] ";
+ $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col];
+ }
+ }
+
+#------------------------------------------------------------------------------
+# Print the maximum metric values found. Each row contains the data for a
+# different metric.
+#------------------------------------------------------------------------------
+ for my $row (keys @transposed_hot_lines)
+ {
+ my $msg = "row[" . $row . "] = ";
+ for my $col (keys @{$transposed_hot_lines[$row]})
+ {
+ $msg .= "$transposed_hot_lines[$row][$col] ";
+ }
+ gp_message ("debugXL", $subr_name, "hot lines = $msg");
+ }
+
+#------------------------------------------------------------------------------
+# Determine the maximum value for each metric.
+#------------------------------------------------------------------------------
+ for my $row (keys @transposed_hot_lines)
+ {
+ my $max_val = 0;
+ for my $col (keys @{$transposed_hot_lines[$row]})
+ {
+ $max_val = max ($transposed_hot_lines[$row][$col], $max_val);
+ }
+#------------------------------------------------------------------------------
+# Convert to a floating point number.
+#------------------------------------------------------------------------------
+ if ($max_val =~ /$integer_only_regex/)
+ {
+ $max_val = sprintf ("%f", $max_val);
+ }
+ push (@max_metric_values, $max_val);
+ }
+
+ for my $metric (keys @max_metric_values)
+ {
+ my $msg = "$input_filename max_metric_values[$metric] = " .
+ $max_metric_values[$metric];
+ gp_message ("debugXL", $subr_name, $msg);
+ }
+
+#------------------------------------------------------------------------------
+# Process those functions that are not the current target.
+#------------------------------------------------------------------------------
+ $modified_html_ref = process_non_target_source ($start_all_source,
+ $start_target_source-1,
+ $src_times_regex,
+ $function_regex,
+ $number_of_metrics,
+ \@file_contents,
+ \@modified_html);
+ @modified_html = @{ $modified_html_ref };
+
+#------------------------------------------------------------------------------
+# This is the core part to process the information for the target function.
+#------------------------------------------------------------------------------
+ gp_message ("debugXL", $subr_name, "parse and process the target source");
+ $modified_html_ref = process_target_source ($start_target_source,
+ $end_target_source,
+ $routine,
+ \@max_metric_values,
+ $src_times_regex,
+ $function2_regex,
+ $number_of_metrics,
+ \@file_contents,
+ \@modified_html);
+ @modified_html = @{ $modified_html_ref };
+
+ if ($end_target_source < $#file_contents)
+ {
+ $modified_html_ref = process_non_target_source ($end_target_source+1,
+ $#file_contents,
+ $src_times_regex,
+ $function_regex,
+ $number_of_metrics,
+ \@file_contents,
+ \@modified_html);
+ @modified_html = @{ $modified_html_ref };
+ }
+
+ gp_message ("debug", $subr_name, "completed reading source");
+
+#------------------------------------------------------------------------------
+# Add an extra line with diagnostics.
+#
+# TBD: The same is done in generate_dis_html but should be done only once.
+#------------------------------------------------------------------------------
+ if ($hp_value > 0)
+ {
+ my $rounded_percentage = sprintf ("%.1f", $hp_value);
+ $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
+ }
+ else
+ {
+ $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
+ }
+
+ $html_home = ${ generate_home_link ("left") };
+ $html_end = ${ terminate_html_document () };
+
+ push (@modified_html, "</pre>");
+ push (@modified_html, "<br>");
+ push (@modified_html, $threshold_line);
+ push (@modified_html, $html_home);
+ push (@modified_html, "<br>");
+ push (@modified_html, $g_html_credits_line);
+ push (@modified_html, $html_end);
+
+ for my $i (0 .. $#modified_html)
+ {
+ gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
+ }
+
+#------------------------------------------------------------------------------
+# Write the generated HTML text to file.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#modified_html)
+ {
+ print NEW_HTML "$modified_html[$i]" . "\n";
+ }
+ close (NEW_HTML);
+ close (SRC_LISTING);
+
+ return ($found_target);
+
+} #-- End of subroutine process_source
+
+#------------------------------------------------------------------------------
+# Process the source lines for the target function.
+#------------------------------------------------------------------------------
+sub process_target_source
+{
+ my $subr_name = get_my_name ();
+
+ my ($start_scan, $end_scan, $target_function, $max_metric_values_ref,
+ $src_times_regex, $function2_regex, $number_of_metrics,
+ $file_contents_ref, $modified_html_ref) = @_;
+
+ my @file_contents = @{ $file_contents_ref };
+ my @modified_html = @{ $modified_html_ref };
+ my @max_metric_values = @{ $max_metric_values_ref };
+
+ my @components = ();
+
+ my $colour_coded_line;
+ my $colour_coded_line_ref;
+ my $hot_line;
+ my $input_line;
+ my $line_id;
+ my $modified_line;
+ my $metric_values;
+ my $src_code_line;
+ my $src_line_no;
+
+ gp_message ("debug", $subr_name, "parse and process the core loop");
+
+ for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++)
+ {
+ $input_line = $file_contents[$line_number];
+
+#------------------------------------------------------------------------------
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
+
+ $line_id = extract_source_line_number ($src_times_regex,
+ $function2_regex,
+ $number_of_metrics,
+ $input_line);
+
+ gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id");
+
+ if ($input_line =~ /$function2_regex/)
+#------------------------------------------------------------------------------
+# Found the function marker.
+#------------------------------------------------------------------------------
+ {
+ if (defined ($1) and defined ($2))
+ {
+ my $func_name_in_file = $2;
+ my $spaces = $1;
+ my $boldface = $TRUE;
+ gp_message ("debug", $subr_name, "function_name = $2");
+ my $function_line = "<Function: " . $func_name_in_file . ">";
+ my $color_function_name = color_string (
+ $function_line,
+ $boldface,
+ $g_html_color_scheme{"target_function_name"});
+ my $ftag;
+ if (exists ($g_function_tag_id{$target_function}))
+ {
+ $ftag = $g_function_tag_id{$target_function};
+ gp_message ("debug", $subr_name, "target_function = $target_function ftag = $ftag");
+ }
+ else
+ {
+ my $msg = "no ftag found for $target_function";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ $modified_line = "<a id=\"" . $ftag . "\"></a>";
+ $modified_line .= $spaces . "<i>" . $color_function_name . "</i>";
+ }
+ }
+ elsif ($input_line =~ /$src_times_regex/)
+#------------------------------------------------------------------------------
+# This is a line with metric values.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("debug", $subr_name, "input line has metrics");
+
+ $hot_line = $1;
+ $metric_values = $2;
+ $src_line_no = $3;
+ $src_code_line = $4;
+
+ gp_message ("debug", $subr_name, "hot_line = $hot_line");
+ gp_message ("debug", $subr_name, "metric_values = $metric_values");
+ gp_message ("debug", $subr_name, "src_line_no = $src_line_no");
+ gp_message ("debug", $subr_name, "src_code_line = $src_code_line");
+
+ if ($hot_line eq "##")
+#------------------------------------------------------------------------------
+# Highlight the most expensive line.
+#------------------------------------------------------------------------------
+ {
+ @components = split (" ", $input_line, 1+$number_of_metrics+2);
+ $modified_line = set_background_color_string (
+ $input_line,
+ $g_html_color_scheme{"background_color_hot"});
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# Highlight those lines close enough to the most expensive line.
+#------------------------------------------------------------------------------
+ @components = split (" ", $input_line, $number_of_metrics + 2);
+ for my $i (0 .. $number_of_metrics-1)
+ {
+ gp_message ("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]");
+ }
+
+ $colour_coded_line_ref = check_metric_values ($metric_values, \@max_metric_values);
+
+ $colour_coded_line = $ {$colour_coded_line_ref};
+ if ($colour_coded_line)
+ {
+ gp_message ("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line");
+ $modified_line = set_background_color_string ($input_line, $g_html_color_scheme{"background_color_lukewarm"});
+ }
+ else
+ {
+ $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
+ $modified_line .= "$input_line";
+ }
+ }
+ }
+ else
+#------------------------------------------------------------------------------
+# This is a regular line that is not modified.
+#------------------------------------------------------------------------------
+ {
+#------------------------------------------------------------------------------
+# Add an id.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "$line_number : input line is a regular line");
+ $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
+ $modified_line .= "$input_line";
+ }
+ gp_message ("debug", $subr_name, "$line_number : mod = $modified_line");
+ push (@modified_html, $modified_line);
+ }
+
+ return (\@modified_html);
+
+} #-- End of subroutine process_target_source
+
+#------------------------------------------------------------------------------
+# Process the options. Set associated variables and check the options for
+# correctness. For example, detect if conflicting options have been set.
+#------------------------------------------------------------------------------
+sub process_user_options
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my %ignored_metrics = ();
+
+ my $error_code;
+ my $message;
+
+ my $outputdir;
+
+ my $target_cmd;
+ my $rm_output_msg;
+ my $mkdir_output_msg;
+ my $time_percentage_multiplier;
+ my $process_all_functions;
+
+ my $option_errors = 0;
+
+#------------------------------------------------------------------------------
+# The -o and -O options are mutually exclusive.
+#------------------------------------------------------------------------------
+ my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
+ my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
+ my $dir_o_option = $g_user_settings{"output"}{"current_value"};
+ my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"};
+
+ if ($define_new_output_dir and $overwrite_output_dir)
+ {
+ my $msg;
+
+ $msg = "the -o/--output and -O/--overwrite options are both set, " .
+ "but are mutually exclusive";
+ push (@g_user_input_errors, $msg);
+
+ $msg = "(setting for -o = $dir_o_option, " .
+ "setting for -O = $dir_O_option)";
+ push (@g_user_input_errors, $msg);
+
+ $option_errors++;
+ }
+
+#------------------------------------------------------------------------------
+# Define the quiet mode. While this is an on/off keyword in the input, we
+# use a boolean in the remainder, because it reads easier.
+#------------------------------------------------------------------------------
+ my $quiet_value = $g_user_settings{"quiet"}{"current_value"};
+ $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
+
+#------------------------------------------------------------------------------
+# In quiet mode, all verbose, warnings and debug messages are suppressed.
+#------------------------------------------------------------------------------
+ if ($g_quiet)
+ {
+ $g_user_settings{"verbose"}{"current_value"} = "off";
+ $g_user_settings{"warnings"}{"current_value"} = "off";
+ $g_user_settings{"debug"}{"current_value"} = "off";
+ $g_verbose = $FALSE;
+ $g_warnings = $FALSE;
+ my $debug_off = "off";
+ my $ignore_value = set_debug_size (\$debug_off);
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# Get the verbose mode.
+#------------------------------------------------------------------------------
+ my $verbose_value = $g_user_settings{"verbose"}{"current_value"};
+ $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
+#------------------------------------------------------------------------------
+# Get the warning mode.
+#------------------------------------------------------------------------------
+ my $warning_value = $g_user_settings{"warnings"}{"current_value"};
+ $g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE;
+ }
+
+#------------------------------------------------------------------------------
+# The value for HP should be in the interval (0,100]. We already enforced
+# the number to be positive, but the limits have not been checked yet.
+#------------------------------------------------------------------------------
+ my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
+
+ if (($hp_value < 0) or ($hp_value > 100))
+ {
+ my $msg = "the value for the highlight percentage is set to $hp_value, ";
+ $msg .= "but must be in the range [0, 100]";
+ push (@g_user_input_errors, $msg);
+
+ $option_errors++;
+ }
+
+#------------------------------------------------------------------------------
+# The value for TP should be in the interval (0,100]. We already enforced
+# the number to be positive, but the limits have not been checked yet.
+#------------------------------------------------------------------------------
+ my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"};
+
+ if (($tp_value < 0) or ($tp_value > 100))
+ {
+ my $msg = "the value for the total percentage is set to $tp_value, " .
+ "but must be in the range (0, 100]";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+ }
+ else
+ {
+ $time_percentage_multiplier = $tp_value/100.0;
+
+# Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.)
+
+ if ($tp_value == 100)
+ {
+ $process_all_functions = $TRUE; # ensure that all routines are handled
+ }
+ else
+ {
+ $process_all_functions = $FALSE;
+ }
+
+ my $txt;
+ $txt = "value of time_percentage_multiplier = " .
+ $time_percentage_multiplier;
+ gp_message ("debugM", $subr_name, $txt);
+ $txt = "value of process_all_functions = " .
+ ($process_all_functions ? "TRUE" : "FALSE");
+ gp_message ("debugM", $subr_name, $txt);
+ }
+
+#------------------------------------------------------------------------------
+# If imetrics has been set, split the list into the individual metrics that
+# need to be excluded. The associated hash called $ignore_metrics has the
+# to be excluded metrics as an index. The value of $TRUE assigned does not
+# really matter.
+#------------------------------------------------------------------------------
+ my @candidate_ignored_metrics;
+
+ if ($g_user_settings{"ignore_metrics"}{"defined"})
+ {
+ @candidate_ignored_metrics =
+ split (":", $g_user_settings{"ignore_metrics"}{"current_value"});
+ }
+ for my $metric (@candidate_ignored_metrics)
+ {
+# TBD: bug? $ignored_metrics{$metric} = $FALSE;
+ $ignored_metrics{$metric} = $TRUE;
+ }
+ for my $metric (keys %ignored_metrics)
+ {
+ my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}";
+ gp_message ("debugM", $subr_name, $txt);
+ }
+
+#------------------------------------------------------------------------------
+# Check if the experiment directories exist.
+#------------------------------------------------------------------------------
+ for my $i (0 .. $#exp_dir_list)
+ {
+ if (-d $exp_dir_list[$i])
+ {
+ my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]);
+ $exp_dir_list[$i] = $abs_path_dir;
+ my $txt = "directory $exp_dir_list[$i] exists";
+ gp_message ("debugM", $subr_name, $txt);
+ }
+ else
+ {
+ my $msg = "directory $exp_dir_list[$i] does not exist";
+
+ push (@g_user_input_errors, $msg);
+ $option_errors++;
+ }
+ }
+
+ return ($option_errors, \%ignored_metrics, $outputdir,
+ $time_percentage_multiplier, $process_all_functions,
+ \@exp_dir_list);
+
+} #-- End of subroutine process_user_options
+
+#------------------------------------------------------------------------------
+# This is a hopefully temporary routine to disable/ignore selected user
+# settings. As the functionality expands, this list will get shorter.
+#------------------------------------------------------------------------------
+sub reset_selected_settings
+{
+ my $subr_name = get_my_name ();
+
+ $g_locale_settings{"decimal_separator"} = "\\.";
+ $g_locale_settings{"convert_to_dot"} = $FALSE;
+ $g_user_settings{func_limit}{current_value} = 1000000;
+
+ gp_message ("debug", $subr_name, "reset selected settings");
+
+ return (0);
+
+} #-- End of subroutine reset_selected_settings
+
+#------------------------------------------------------------------------------
+# There may be various different visibility characters in a metric definition.
+# For example: e+%CPI.
+#
+# Internally we use a normalized definition that only uses the dot (e.g.
+# e.CPI) as an index into the description structure.
+#
+# Here we reduce the incoming metric definition to the normalized form, look
+# up the text, and return a pointer to it.
+#------------------------------------------------------------------------------
+sub retrieve_metric_description
+{
+ my $subr_name = get_my_name ();
+
+ my ($metric_name_ref, $metric_description_ref) = @_;
+
+ my $metric_name = ${ $metric_name_ref };
+ my %metric_description = %{ $metric_description_ref };
+
+ my $description;
+ my $normalized_metric;
+
+ $metric_name =~ /([ei])([\.\+%]+)(.*)/;
+
+ if (defined ($1) and defined ($3))
+ {
+ $normalized_metric = $1 . "." . $3;
+ }
+ else
+ {
+ my $msg = "metric $metric_name has an unknown format";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ if (defined ($metric_description{$normalized_metric}))
+ {
+ $description = $metric_description{$normalized_metric};
+ }
+ else
+ {
+ my $msg = "description for normalized metric $normalized_metric not found";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ return (\$description);
+
+} #-- End of subroutine retrieve_metric_description
+
+#------------------------------------------------------------------------------
+# TBD.
+#------------------------------------------------------------------------------
+sub rnumerically
+{
+ my ($f1,$f2);
+ if ($a =~ /^([^\d]*)(\d+)/)
+ {
+ $f1 = int ($2);
+ if ($b=~ /^([^\d]*)(\d+)/)
+ {
+ $f2 = int ($2);
+ $f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1);
+ }
+ }
+ else
+ {
+ return ($b <=> $a);
+ }
+} #-- End of subroutine rnumerically
+
+#------------------------------------------------------------------------------
+# TBD: Remove - not used any longer.
+# Set the architecture and associated regular expressions.
+#------------------------------------------------------------------------------
+sub set_arch_and_regexes
+{
+ my $subr_name = get_my_name ();
+
+ my ($arch_uname) = @_;
+
+ my $architecture_supported;
+
+ gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
+
+ if ($arch_uname eq "x86_64")
+ {
+ #x86/x64 hardware uses jump
+ $architecture_supported = $TRUE;
+# $arch='x64';
+# $regex=':\s+(j).*0x[0-9a-f]+';
+# $subexp='(\[\s*)(0x[0-9a-f]+)';
+# $linksubexp='(\[\s*)(0x[0-9a-f]+)';
+ gp_message ("debug", $subr_name, "detected $arch_uname hardware");
+
+ $architecture_supported = $TRUE;
+ $g_arch_specific_settings{"arch_supported"} = $TRUE;
+ $g_arch_specific_settings{"arch"} = 'x64';
+ $g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+';
+ $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)';
+ $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)';
+ }
+#-------------------------------------------------------------------------------
+# TBD: Remove the elsif block
+#-------------------------------------------------------------------------------
+ elsif ($arch_uname=~m/sparc/s)
+ {
+ #sparc hardware uses branch
+ $architecture_supported = $FALSE;
+# $arch='sparc';
+# $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
+# $subexp='(\s*)(0x[0-9a-f]+)\s*$';
+# $linksubexp='(\s*)(0x[0-9a-f]+\s*$)';
+# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported");
+ $architecture_supported = $FALSE;
+ $g_arch_specific_settings{arch_supported} = $FALSE;
+ $g_arch_specific_settings{arch} = 'sparc';
+ $g_arch_specific_settings{regex} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
+ $g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$';
+ $g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)';
+ }
+ else
+ {
+ $architecture_supported = $FALSE;
+ gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality");
+ }
+
+ return ($architecture_supported);
+
+} #-- End of subroutine set_arch_and_regexes
+
+#------------------------------------------------------------------------------
+# Set the background color of the input string.
+#
+# For supported colors, see:
+# https://www.w3schools.com/colors/colors_names.asp
+#------------------------------------------------------------------------------
+sub set_background_color_string
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_string, $color) = @_;
+
+ my $background_color_string;
+ my $msg;
+
+ $msg = "color = $color input_string = $input_string";
+ gp_message ("debugXL", $subr_name, $msg);
+
+ $background_color_string = "<span style='background-color: " . $color .
+ "'>" . $input_string . "</span>";
+
+ $msg = "color = $color background_color_string = " .
+ $background_color_string;
+ gp_message ("debugXL", $subr_name, $msg);
+
+ return ($background_color_string);
+
+} #-- End of subroutine set_background_color_string
+
+#------------------------------------------------------------------------------
+# Set the g_debug_size structure for a given value for "size". Also set the
+# value in $g_user_settings{"debug"}{"current_value"}
+#------------------------------------------------------------------------------
+sub set_debug_size
+{
+ my $subr_name = get_my_name ();
+
+ my ($debug_value_ref) = @_;
+
+ my $debug_value = lc (${ $debug_value_ref });
+
+#------------------------------------------------------------------------------
+# Regardless of the value, the debug settings are defined here.
+#------------------------------------------------------------------------------
+ $g_user_settings{"debug"}{"defined"} = $TRUE;
+
+#------------------------------------------------------------------------------
+# By default, set the value to "on", but correct below if needed.
+#------------------------------------------------------------------------------
+ $g_user_settings{"debug"}{"current_value"} = "on";
+
+ if (($debug_value eq "on") or ($debug_value eq "s"))
+ {
+ $g_debug_size{"on"} = $TRUE;
+ $g_debug_size{"s"} = $TRUE;
+ }
+ elsif ($debug_value eq "m")
+ {
+ $g_debug_size{"on"} = $TRUE;
+ $g_debug_size{"s"} = $TRUE;
+ $g_debug_size{"m"} = $TRUE;
+ }
+ elsif ($debug_value eq "l")
+ {
+ $g_debug_size{"on"} = $TRUE;
+ $g_debug_size{"s"} = $TRUE;
+ $g_debug_size{"m"} = $TRUE;
+ $g_debug_size{"l"} = $TRUE;
+ }
+ elsif ($debug_value eq "xl")
+ {
+ $g_debug_size{"on"} = $TRUE;
+ $g_debug_size{"s"} = $TRUE;
+ $g_debug_size{"m"} = $TRUE;
+ $g_debug_size{"l"} = $TRUE;
+ $g_debug_size{"xl"} = $TRUE;
+ }
+ else
+#------------------------------------------------------------------------------
+# Any other value is considered to disable debugging.
+#------------------------------------------------------------------------------
+ {
+ $g_user_settings{"debug"}{"current_value"} = "off";
+ $g_debug_size{"on"} = $FALSE;
+ $g_debug_size{"s"} = $FALSE;
+ $g_debug_size{"m"} = $FALSE;
+ $g_debug_size{"l"} = $FALSE;
+ $g_debug_size{"xl"} = $FALSE;
+ }
+
+#------------------------------------------------------------------------------
+# Activate in case of an emergency :-)
+#------------------------------------------------------------------------------
+## if ($g_debug_size{$debug_value})
+## {
+## for my $i (keys %g_debug_size)
+## {
+## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n";
+## }
+## }
+
+ return (0);
+
+} #-- End of subroutine set_debug_size
+
+#------------------------------------------------------------------------------
+# This subroutine defines the default metrics.
+#------------------------------------------------------------------------------
+sub set_default_metrics
+{
+ my $subr_name = get_my_name ();
+
+ my ($outfile1, $ignored_metrics_ref) = @_;
+
+ my %ignored_metrics = %{ $ignored_metrics_ref };
+
+ my %metric_description = ();
+ my %metric_found = ();
+
+ my $detail_metrics;
+ my $detail_metrics_system;
+
+ my $call_metrics = "";
+ my $summary_metrics = "";
+
+ open (METRICS, "<", $outfile1)
+ or die ("Unable to open metrics file $outfile1 for reading - '$!'");
+ gp_message ("debug", $subr_name, "opened $outfile1 for reading");
+
+ while (<METRICS>)
+ {
+ my $metric_line = $_;
+ chomp ($metric_line);
+
+ gp_message ("debug", $subr_name,"the value of metric_line = $metric_line");
+
+#------------------------------------------------------------------------------
+# Decode the metric part of the input line. If a valid line, return the
+# metric components. Otherwise return "skipped" in the metric_spec field.
+#------------------------------------------------------------------------------
+ my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line);
+
+ gp_message ("debug", $subr_name, "metric_spec = $metric_spec");
+ gp_message ("debug", $subr_name, "metric_flavor = $metric_flavor");
+
+ if ($metric_spec eq "skipped")
+#------------------------------------------------------------------------------
+# Not a valid input line.
+#------------------------------------------------------------------------------
+ {
+ gp_message ("debug", $subr_name, "skipped line: $metric_line");
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# A valid metric field has been found.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "metric_name = $metric_name");
+ gp_message ("debug", $subr_name, "metric_description = $metric_description");
+
+# if (exists ($IMETRICS{$m})){
+ if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name}))
+ {
+ gp_message ("debug", $subr_name, "user requested to ignore metric $metric_name");
+ next;
+ }
+
+#------------------------------------------------------------------------------
+# Only the exclusive metric is selected.
+#------------------------------------------------------------------------------
+ if ($metric_flavor eq "e")
+ {
+ $metric_found{$metric_spec} = $TRUE;
+ $metric_description{$metric_spec} = $metric_description;
+
+# TBD: remove the -AO:
+ gp_message ("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}");
+
+ $summary_metrics .= $metric_spec.":";
+ $call_metrics .= "a.".$metric_name.":";
+ }
+ }
+ }
+ close (METRICS);
+
+ chop ($call_metrics);
+ chop ($summary_metrics);
+
+ $detail_metrics = $summary_metrics;
+ $detail_metrics_system = $summary_metrics;
+
+ return (\%metric_description, \%metric_found,
+ $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
+
+} #-- End of subroutine set_default_metrics
+
+#------------------------------------------------------------------------------
+# Set various system specific variables. These depend upon both the processor
+# architecture and OS. The values are stored in global structure
+# g_arch_specific_settings.
+#------------------------------------------------------------------------------
+sub set_system_specific_variables
+{
+ my $subr_name = get_my_name ();
+
+ my ($arch_uname, $arch_uname_s) = @_;
+
+ my $elf_arch;
+ my $read_elf_cmd;
+ my $elf_support;
+ my $architecture_supported;
+ my $arch;
+ my $regex;
+ my $subexp;
+ my $linksubexp;
+
+ if ($arch_uname eq "x86_64")
+ {
+#------------------------------------------------------------------------------
+# x86/x64 hardware uses jump
+#------------------------------------------------------------------------------
+ $architecture_supported = $TRUE;
+ $arch = 'x64';
+ $regex =':\s+(j).*0x[0-9a-f]+';
+ $subexp ='(\[\s*)(0x[0-9a-f]+)';
+ $linksubexp ='(\[\s*)(0x[0-9a-f]+)';
+
+# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch");
+
+ $g_arch_specific_settings{"arch_supported"} = $TRUE;
+ $g_arch_specific_settings{"arch"} = 'x64';
+#------------------------------------------------------------------------------
+# Define the regular expressions to parse branch instructions.
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# TBD: Need much more than these
+#------------------------------------------------------------------------------
+ $g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
+ $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)';
+ $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)';
+ }
+ else
+ {
+ $architecture_supported = $FALSE;
+ $g_arch_specific_settings{"arch_supported"} = $FALSE;
+ }
+
+#------------------------------------------------------------------------------
+# TBD Ruud: need to handle this better
+#------------------------------------------------------------------------------
+ if ($arch_uname_s eq "Linux")
+ {
+ $elf_arch = $arch_uname_s;
+ $read_elf_cmd = $g_mapped_cmds{"readelf"};
+
+ if ($read_elf_cmd eq "road_to_nowhere")
+ {
+ $elf_support = $FALSE;
+ }
+ else
+ {
+ $elf_support = $TRUE;
+ }
+ gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch");
+ }
+ else
+ {
+ gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported");
+ }
+
+ return ($architecture_supported, $elf_arch, $elf_support);
+
+} #-- End of subroutine set_system_specific_variables
+
+#------------------------------------------------------------------------------
+# TBD
+#------------------------------------------------------------------------------
+sub set_title
+{
+ my $subr_name = get_my_name ();
+
+ my ($function_info_ref, $func, $from_where) = @_ ;
+
+ my $msg;
+ my @function_info = @{$function_info_ref};
+ my $filename = $func ;
+
+ my $base;
+ my $first_line;
+ my $src_file;
+ my $RI;
+ my $the_title;
+ my $routine = "?";
+ my $DIS;
+ my $SRC;
+
+ chomp ($filename);
+
+ $base = get_basename ($filename);
+
+ gp_message ("debug", $subr_name, "from_where = $from_where");
+ gp_message ("debug", $subr_name, "base = $base filename = $filename");
+
+ if ($from_where eq "process source")
+ {
+ if ($base =~ /^file\.(\d+)\.src\.txt$/)
+ {
+ if (defined ($1))
+ {
+ $RI = $1;
+ }
+ else
+ {
+ $msg = "unexpected error encountered parsing $filename";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ $the_title = "Source";
+ }
+ elsif ($from_where eq "disassembly")
+ {
+ if ($base =~ /^file\.(\d+)\.dis$/)
+ {
+ if (defined ($1))
+ {
+ $RI = $1;
+ }
+ else
+ {
+ $msg = "unexpected error encountered parsing $filename";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+ }
+ $the_title = "Disassembly";
+ }
+ else
+ {
+ $msg = "called from unknown routine - $from_where";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ if (defined ($function_info[$RI]{"routine"}))
+ {
+ $routine = $function_info[$RI]{"routine"};
+ }
+
+ if ($from_where eq "process source")
+ {
+ my $is_empty = is_file_empty ($filename);
+
+ if ($is_empty)
+ {
+ $src_file = "";
+ }
+ else
+ {
+ open ($SRC, "<", $filename)
+ or die ("$subr_name - unable to open source file $filename for reading:'$!'");
+ gp_message ("debug", $subr_name, "opened file $filename for reading");
+
+ $first_line = <$SRC>;
+ chomp ($first_line);
+
+ close ($SRC);
+
+ gp_message ("debug", $subr_name, "first_line = $first_line");
+
+ if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
+ {
+ $src_file = $1
+ }
+ else
+ {
+ $src_file = "";
+ }
+ }
+ }
+ elsif ($from_where eq "disassembly")
+ {
+ open ($DIS, "<", $filename)
+ or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
+ gp_message ("debug", $subr_name, "opened file $filename for reading");
+
+ $first_line = <$DIS>;
+ close ($DIS);
+
+ if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
+ {
+ $src_file = "$1"
+ }
+ else
+ {
+ $src_file = "";
+ }
+ }
+
+ if (length ($routine))
+ {
+ $the_title .= " $routine";
+ }
+
+ if (length ($src_file))
+ {
+ if ($src_file ne "(unknown)")
+ {
+ $the_title .= " ($src_file)";
+ }
+ else
+ {
+ $the_title .= " $src_file";
+ }
+ }
+
+ return ($the_title);
+
+} #-- End of subroutine set_title
+
+#------------------------------------------------------------------------------
+# Handles where the output should go. If needed, a directory is # created
+# where the results will go.
+#------------------------------------------------------------------------------
+sub set_up_output_directory
+{
+ my $subr_name = get_my_name ();
+
+ my $error_code;
+ my $message;
+ my $mkdir_output_msg;
+ my $option_errors;
+ my $outputdir = "does_not_exist_yet";
+ my $rm_output_msg;
+ my $target_cmd;
+
+ my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
+ my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
+
+ $option_errors = 0;
+
+ if ((not $define_new_output_dir) and (not $overwrite_output_dir))
+#------------------------------------------------------------------------------
+# If neither -o or -O are set, find the next number to be used in the name for
+# the default output directory.
+#------------------------------------------------------------------------------
+ {
+ my $dir_id = 1;
+ while (-d "display.".$dir_id.".html")
+ { $dir_id++; }
+ $outputdir = "display.".$dir_id.".html";
+ }
+ elsif ($define_new_output_dir)
+#------------------------------------------------------------------------------
+# The output directory is defined with the -o option.
+#------------------------------------------------------------------------------
+ {
+ $outputdir = $g_user_settings{"output"}{"current_value"};
+ }
+ elsif ($overwrite_output_dir)
+#------------------------------------------------------------------------------
+# The output directory is defined with the -O option.
+#------------------------------------------------------------------------------
+ {
+ $outputdir = $g_user_settings{"overwrite"}{"current_value"};
+ }
+
+#------------------------------------------------------------------------------
+# The name of the output directory is known and we can proceed.
+#------------------------------------------------------------------------------
+ gp_message ("debug", $subr_name, "the target output directory is $outputdir");
+
+ if (-d $outputdir)
+ {
+#------------------------------------------------------------------------------
+# The -o option is used, but the directory already exists.
+#------------------------------------------------------------------------------
+ if ($define_new_output_dir)
+ {
+ $message = "directory $outputdir already exists";
+ $message .= " (use the -O option to overwrite an existing directory)";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+
+ return ($option_errors, $outputdir);
+ }
+ elsif ($overwrite_output_dir)
+#------------------------------------------------------------------------------
+# It is a bit risky to remove this directory and so we proceed with caution.
+# What if the user decides to call it "*" e.g. "-O \*" for example? While this
+# should have been caught when processing the options, we still like to
+# be very cautious here before executing /bin/rm -rf.
+#------------------------------------------------------------------------------
+ {
+ if ($outputdir eq "*")
+ {
+ $message = "it is not allowed to use * as a value for the -O option";
+ push (@g_user_input_errors, $message);
+
+ $option_errors++;
+
+ return ($option_errors, $outputdir);
+ }
+ else
+ {
+#------------------------------------------------------------------------------
+# The output directory exists, but it is okay to overwrite it. It is
+# removed here and created again below.
+#------------------------------------------------------------------------------
+ $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir;
+ ($error_code, $rm_output_msg) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+ {
+ gp_message ("error", $subr_name, $rm_output_msg);
+ gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "directory $outputdir has been removed");
+ }
+ }
+ }
+ } #-- End of if-check for $outputdir
+
+#-------------------------------------------------------------------------------
+# When we get here, the fatal scenarios have been cleared and the name for
+# $outputdir is known. Time to create it. Note that recursive creation is
+# supported and umask controls the access permissions.
+#-------------------------------------------------------------------------------
+ $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir;
+ ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd);
+
+ if ($error_code != 0)
+ {
+ my $msg = "a fatal problem occurred when creating directory $outputdir";
+ gp_message ("abort", $subr_name, $msg);
+ }
+ else
+ {
+ gp_message ("debug", $subr_name, "created output directory $outputdir");
+ }
+
+ return ($option_errors, $outputdir);
+
+} #-- End of subroutine set_up_output_directory
+
+#------------------------------------------------------------------------------
+# Routine to generate webfriendly names
+#------------------------------------------------------------------------------
+sub tag_name
+{
+ my $subr_name = get_my_name ();
+
+ my ($target_name) = @_;
+
+#------------------------------------------------------------------------------
+# Keeps track how many names have been tagged already.
+#------------------------------------------------------------------------------
+ state $S_total_tagged_names = 0;
+
+ my $unique_name;
+
+ gp_message ("debug", $subr_name, "target_name on entry = $target_name");
+
+#------------------------------------------------------------------------------
+# Undo conversion of < in to <
+#------------------------------------------------------------------------------
+
+#------------------------------------------------------------------------------
+# TBD: Legacy - What is going on here and is this really needed?!
+# We need to replace the "<" symbol in the code by "<".
+#------------------------------------------------------------------------------
+ $target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g;
+
+#------------------------------------------------------------------------------
+# Remove inlining info
+#------------------------------------------------------------------------------
+ $target_name =~ s/, instructions from source file.*//;
+
+ if (defined $g_tagged_names{$target_name})
+ {
+ gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}");
+ gp_message ("debug", $subr_name, "target_name on return = $target_name");
+ return ($g_tagged_names{$target_name});
+ }
+ else
+ {
+ $unique_name = "ftag".$S_total_tagged_names;
+ $S_total_tagged_names++;
+ $g_tagged_names{$target_name} = $unique_name;
+ gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}");
+ gp_message ("debug", $subr_name, "target_name on return = $target_name");
+ return ($unique_name);
+ }
+
+} #-- End of subroutine tag_name
+
+#------------------------------------------------------------------------------
+# Generate a string to terminate the HTML document.
+#------------------------------------------------------------------------------
+sub terminate_html_document
+{
+ my $subr_name = get_my_name ();
+
+ my $html_line;
+
+ $html_line = "</body>\n";
+ $html_line .= "</html>";
+
+ return (\$html_line);
+
+} #-- End of subroutine terminate_html_document
+
+#-------------------------------------------------------------------------------
+# Perform some basic checks to ensure the input data is consistent. This part
+# could be refined and expanded over time. For example by using a checksum
+# mechanism to verify the consistency of the executables.
+#-------------------------------------------------------------------------------
+sub verify_consistency_experiments
+{
+ my $subr_name = get_my_name ();
+
+ my ($exp_dir_list_ref) = @_;
+
+ my @exp_dir_list = @{ $exp_dir_list_ref };
+
+ my $executable_name;
+ my $full_path_executable_name;
+ my $ref_executable_name;
+
+ my $first_exp_dir = $TRUE;
+ my $count_differences = 0;
+
+#-------------------------------------------------------------------------------
+# Enforce that the full path names to the executable are the same. This could
+# be overkill and a checksum approach would be more flexible.
+#-------------------------------------------------------------------------------
+ for my $full_exp_dir (@exp_dir_list)
+ {
+ my $exp_dir = get_basename ($full_exp_dir);
+ gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
+ if ($first_exp_dir)
+ {
+ $first_exp_dir = $FALSE;
+ $ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
+ gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name");
+ next;
+ }
+ $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
+ gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name");
+
+ if ($full_path_executable_name ne $ref_executable_name)
+ {
+ $count_differences++;
+ gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name");
+ }
+ }
+
+ $executable_name = get_basename ($ref_executable_name);
+
+ return ($count_differences, $executable_name);
+
+} #-- End of subroutine verify_consistency_experiments
+
+#------------------------------------------------------------------------------
+# Check if the input item is valid for the data type specified. Validity is
+# verified in the context of gprofng. The definition for the metrics is a
+# good example of that.
+#------------------------------------------------------------------------------
+sub verify_if_input_is_valid
+{
+ my $subr_name = get_my_name ();
+
+ my ($input_item, $data_type) = @_;
+
+ my $return_value = $FALSE;
+
+#------------------------------------------------------------------------------
+# These value are allowed to be case insensitive, so we convert to lower
+# case first.
+#------------------------------------------------------------------------------
+ if (($data_type eq "onoff") or ($data_type eq "size"))
+ {
+ $input_item = lc ($input_item);
+ }
+
+ if ($data_type eq "metrics")
+#------------------------------------------------------------------------------
+# A gprofng metric definition. Either consists of "default" only, or starts
+# with e or i, followed by one or more from the set {.,%,!,+} and a keyword.
+# This pattern may be repeated with a ":" as the separator.
+#------------------------------------------------------------------------------
+ {
+ my @metric_list = split (":", $input_item);
+
+#------------------------------------------------------------------------------
+# Check if the pattern is valid. If not, bail out and return $FALSE.
+#------------------------------------------------------------------------------
+ for my $metric (@metric_list)
+ {
+ if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/)
+ {
+ $return_value = $TRUE;
+ }
+ else
+ {
+ $return_value = $FALSE;
+ last;
+ }
+ }
+ }
+ elsif ($data_type eq "metric_names")
+#------------------------------------------------------------------------------
+# A gprofng metric definition but without the flavour and visibility . Either
+# the name consists of "default" only, or a keyword with lowercase letters
+# only. This pattern may be repeated with a ":" as the separator.
+#------------------------------------------------------------------------------
+ {
+ my @metric_list = split (":", $input_item);
+
+#------------------------------------------------------------------------------
+# Check if the pattern is valid. If not, bail out and return $FALSE.
+#------------------------------------------------------------------------------
+ for my $metric (@metric_list)
+ {
+ if ($metric =~ /^default$|^[a-z]*$/)
+ {
+ $return_value = $TRUE;
+ }
+ else
+ {
+ $return_value = $FALSE;
+ last;
+ }
+ }
+ }
+ elsif ($data_type eq "path")
+#------------------------------------------------------------------------------
+# This can be almost anything, including "/" and "."
+#------------------------------------------------------------------------------
+ {
+ if ($input_item =~ /^[\w\/\.]*$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "boolean")
+ {
+#------------------------------------------------------------------------------
+# This is TRUE (=1) or FALSE (0).
+#------------------------------------------------------------------------------
+ if ($input_item =~ /^[01]$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "onoff")
+#------------------------------------------------------------------------------
+# This is either "on" OR "off".
+#------------------------------------------------------------------------------
+ {
+ if ($input_item =~ /^on$|^off$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "size")
+#------------------------------------------------------------------------------
+# Supported values are "on", "off", "s", "m", "l", OR "xl".
+#------------------------------------------------------------------------------
+ {
+ if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "pinteger")
+#------------------------------------------------------------------------------
+# This is a positive integer.
+#------------------------------------------------------------------------------
+ {
+ if ($input_item =~ /^\d*$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "integer")
+#------------------------------------------------------------------------------
+# This is a positive or negative integer.
+#------------------------------------------------------------------------------
+ {
+ if ($input_item =~ /^\-?\d*$/)
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "pfloat")
+#------------------------------------------------------------------------------
+# This is a positive floating point number, but we accept a positive integer
+# number as well.
+#
+# TBD: Note that we use the "." here. Maybe should support a "," too.
+#------------------------------------------------------------------------------
+ {
+ if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/))
+ {
+ $return_value = $TRUE;
+ }
+ }
+ elsif ($data_type eq "float")
+#------------------------------------------------------------------------------
+# This is a positive or negative floating point number, but we accept an
+# integer number as well.
+#
+# TBD: Note that we use the "." here. Maybe should support a "," too.
+#------------------------------------------------------------------------------
+ {
+ if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/))
+ {
+ $return_value = $TRUE;
+ }
+ }
+ else
+ {
+ my $msg = "the $data_type data type for input $input_item is not supported";
+ gp_message ("assertion", $subr_name, $msg);
+ }
+
+ return ($return_value);
+
+} #-- End of subroutine verify_if_input_is_valid
projects / binutils-gdb.git / commitdiff