diff options
| author | Ruud van der Pas <ruud.vanderpas@oracle.com> | 2022-06-28 10:37:19 -0700 |
|---|---|---|
| committer | Vladimir Mezentsev <vladimir.mezentsev@oracle.com> | 2022-07-06 14:39:33 -0700 |
| commit | 41bbac64c36ffc5a418524be55fde20fad888e11 (patch) | |
| tree | 2543c9febd79d48d60b694a8748c7b0dacc21164 /gprofng | |
| parent | fb5a4a581d4fbd02ae41e034439872a169e43f0b (diff) | |
| download | gdb-41bbac64c36ffc5a418524be55fde20fad888e11.zip gdb-41bbac64c36ffc5a418524be55fde20fad888e11.tar.gz gdb-41bbac64c36ffc5a418524be55fde20fad888e11.tar.bz2 | |
gprofng: implement a functional gp-display-html
This patch enables the first support for the "gprofng display html" command.
This command works for C/C++ applications on x86_64. Using one or more gprofng
experiment directories as input, a new directory with html files is created.
Through the index.html file in this directory, the performance results may be
viewed in a browser.
gprofng/Changelog:
2022-06-28 Ruud van der Pas <ruud.vanderpas@oracle.com>
* gp-display-html/gp-display-html.in: implement first support for x86_64 and C/C++
Diffstat (limited to 'gprofng')
| -rw-r--r-- | gprofng/gp-display-html/gp-display-html.in | 14555 |
1 files changed, 14430 insertions, 125 deletions
diff --git a/gprofng/gp-display-html/gp-display-html.in b/gprofng/gp-display-html/gp-display-html.in index f8fbc24..54a87d7 100644 --- a/gprofng/gp-display-html/gp-display-html.in +++ b/gprofng/gp-display-html/gp-display-html.in @@ -1,5 +1,4 @@ -#!/usr/bin/perl - +#!/usr/bin/env perl # Copyright (C) 2021 Free Software Foundation, Inc. # Contributed by Oracle. # @@ -20,14 +19,34 @@ # Foundation, 51 Franklin Street - Fifth Floor, Boston, # MA 02110-1301, USA. +use strict; +use warnings; +use feature qw (state); +use File::stat; + #------------------------------------------------------------------------------ -# gp-display-html, last updated July 2021 -# -# NOTE: This is a skeleton version. The real code will follow as an update. +# Check as early as possible if the version of Perl used is supported. #------------------------------------------------------------------------------ +INIT +{ + my $perl_minimal_version_supported = version->parse ("5.10.0")->normal; + my $perl_current_version = version->parse ("$]")->normal; -use strict; -use warnings; + if ($perl_current_version lt $perl_minimal_version_supported) + { + my $msg; + + $msg = "Error: minimum Perl release required: "; + $msg .= $perl_minimal_version_supported; + $msg .= " current: "; + $msg .= $perl_current_version; + $msg .= "\n"; + + print $msg; + + exit (1); + } +} #-- End of INIT #------------------------------------------------------------------------------ # Poor man's version of a boolean. @@ -35,222 +54,14508 @@ use warnings; my $TRUE = 1; my $FALSE = 0; +my $g_max_length_first_metric; + +#------------------------------------------------------------------------------- +# Code debugging flag +#------------------------------------------------------------------------------- +my $g_test_code = $FALSE; + +#------------------------------------------------------------------------------- +# GPROFNG commands and files used. +#------------------------------------------------------------------------------- +my $GP_DISPLAY_TEXT = "gp-display-text"; + +my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; +my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log"; + +#------------------------------------------------------------------------------ +# Global variables. +#------------------------------------------------------------------------------ +my $g_addressing_mode = "64 bit"; + +#------------------------------------------------------------------------------ +# The global regex section. +# +# First step towards consolidating all regexes. +#------------------------------------------------------------------------------ + my $g_less_than_regex = '<'; + my $g_html_less_than_regex = '<'; + my $g_endbr_inst_regex = 'endbr[32|64]'; + +#------------------------------------------------------------------------------ +# These are the regex's used. +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ +# Disassembly analysis +#------------------------------------------------------------------------------ + my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; + my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; + my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; + +#------------------------------------------------------------------------------ +# Convenience. These map the on/off value to $TRUE/$FALSE to make the code +# easier to read. For example: "if ($g_verbose)" as opposed to the following: +# "if ($verbose_setting eq "on"). +#------------------------------------------------------------------------------ +my $g_verbose; +my $g_warnings; +my $g_quiet; + +my $g_first_metric; + +my $binutils_version; +my $driver_cmd; +my $tool_name; +my $version_info; + +my %g_mapped_cmds = (); + +#------------------------------------------------------------------------------ +# TBD All warning messages are collected and are accessible through the main +# page. +#------------------------------------------------------------------------------ +my @g_warning_messages = (); + +#------------------------------------------------------------------------------ +# Contains the names that have already been tagged. This is a global +# structure because otherwise the code would get much more complicated. +#------------------------------------------------------------------------------ +my %g_tagged_names = (); + +#------------------------------------------------------------------------------ +# TBD Remove the use of these structures. No longer used. +#------------------------------------------------------------------------------ +my %g_function_tag_id = (); +my $g_context = 5; # Defines the range of scan + +my $g_default_setting_lang = "en-US.UTF-8"; +my %g_exp_dir_meta_data; + +my @g_user_input_errors = (); + +my $g_html_credits_line; + +my $g_warn_keyword = "Input warning: "; +my $g_error_keyword = "Input error: "; + +my %g_function_occurrences = (); +my %g_map_function_to_index = (); +my %g_multi_count_function = (); +my %g_function_view_all = (); +my @g_full_function_view_table = (); + +my @g_html_experiment_stats = (); + +#------------------------------------------------------------------------------- +# These structures contain the information printed in the function views. +#------------------------------------------------------------------------------- +my $g_header_lines; + +my @g_html_function_name = (); + +#------------------------------------------------------------------------------- +# TBD: This variable may not be needed and replaced by tp_value +my $thresh = 0; +#------------------------------------------------------------------------------- + #------------------------------------------------------------------------------- # Define the driver command, tool name and version number. #------------------------------------------------------------------------------- -my $driver_cmd = "gprofng display html"; -my $tool_name = "gp-display-html"; -my $binutils_version = "BINUTILS_VERSION"; -my $version_info = $tool_name . " GNU binutils version " . $binutils_version; +$driver_cmd = "gprofng display html"; +$tool_name = "gp-display-html"; +#$binutils_version = "2.38.50"; +$binutils_version = "BINUTILS_VERSION"; +$version_info = $tool_name . " GNU binutils version " . $binutils_version; + +#------------------------------------------------------------------------------- + +#------------------------------------------------------------------------------- +# Define several key data structures. +#------------------------------------------------------------------------------- +my %g_user_settings = + ( + output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, + overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, + calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, + func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE}, + highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE}, + threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE}, + default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, + ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE}, + verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, + warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE}, + debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE}, + quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, + ); + +my %g_debug_size = + ( + "on" => $FALSE, + "s" => $FALSE, + "m" => $FALSE, + "l" => $FALSE, + "xl" => $FALSE, + ); + +my %local_system_config = + ( + kernel_name => "undefined", + nodename => "undefined", + kernel_release => "undefined", + kernel_version => "undefined", + machine => "undefined", + processor => "undefined", + hardware_platform => "undefined", + operating_system => "undefined", + hostname_current => "undefined", + ); + +# Note that we use single quotes here, because regular expressions wreak havoc otherwise. + +my %g_arch_specific_settings = + ( + arch_supported => $FALSE, + arch => 'undefined', + regex => 'undefined', + subexp => 'undefined', + linksubexp => 'undefined', + ); + +my %g_locale_settings = ( + LANG => "en_US.UTF-8", + decimal_separator => "\\.", + covert_to_dot => $FALSE +); #------------------------------------------------------------------------------ -# This is cosmetic, but helps with the scoping of variables. +# See this page for a nice overview with the colors: +# https://www.w3schools.com/colors/colors_groups.asp #------------------------------------------------------------------------------ - main (); +my %g_html_color_scheme = ( + "control_flow" => "Brown", + "target_function_name" => "Red", + "non_target_function_name" => "BlueViolet", + "background_color_hot" => "PeachPuff", + "background_color_lukewarm" => "LemonChiffon", + "link_outside_range" => "Crimson", + "error_message" => "LightPink", + "background_color_page" => "White", +# "background_color_page" => "LightGray", + "background_selected_sort" => "LightSlateGray", + "index" => "Lavender", +); - exit (0); +#------------------------------------------------------------------------------ +# These are the base names for the HTML files that are generated. +#------------------------------------------------------------------------------ +my %g_html_base_file_name = ( + "caller_callee" => "caller-callee", + "disassembly" => "dis", + "experiment_info" => "experiment-info", + "function_view" => "function-view-sorted", + "index" => "index", + "source" => "src", + "warnings" => "warnings", +); #------------------------------------------------------------------------------ -# THE SUBROUTINES +# This is cosmetic, but helps with the scoping of variables. #------------------------------------------------------------------------------ + main (); + + exit (0); #------------------------------------------------------------------------------ # This is the driver part of the program. #------------------------------------------------------------------------------ -sub -main +sub main { - my $subr_name = "main"; - my $ignore_value; + my $subr_name = get_my_name (); + +#------------------------------------------------------------------------------ +# The name of the configuration file. +#------------------------------------------------------------------------------ + my $rc_file_name = ".gp-display-html.rc"; + +#------------------------------------------------------------------------------ +# 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); + +#------------------------------------------------------------------------------ +# TBD: Eliminate these. +#------------------------------------------------------------------------------ + my $ARCHIVES_MAP_NAME; + my $ARCHIVES_MAP_VADDR; + +#------------------------------------------------------------------------------ +# Local structures (hashes and arrays). +#------------------------------------------------------------------------------ + my @exp_dir_list; # List with experiment directories + my @metrics_data; + + my %function_address_info = (); + my $function_address_info_ref; + + my @function_info = (); + my $function_info_ref; + + my %function_address_and_index = (); + my $function_address_and_index_ref; + + my %addressobjtextm = (); + my $addressobjtextm_ref; + + my %addressobj_index = (); + my $addressobj_index_ref; + + my %LINUX_vDSO = (); + my $LINUX_vDSO_ref; + + my %function_view_structure = (); + my $function_view_structure_ref; + + my %elf_rats = (); + my $elf_rats_ref; + +#------------------------------------------------------------------------------ +# Local variables. +#------------------------------------------------------------------------------ + my $abs_path_outputdir; + my $archive_dir_not_empty; + my $base_va_executable; + my $executable_name; + my $exp_dir_list_ref; + my $found_exp_dir; + my $ignore_value; + my $message; + my $number_of_metrics; + my $va_executable_in_hex; + + my $failed_command_mappings; + my $option_errors; + my $total_user_errors; + + my $script_pc_metrics; + my $dir_check_errors; + my $consistency_errors; + my $outputdir; + my $return_code; + + my $decimal_separator; + my $convert_to_dot; + my $architecture_supported; + my $elf_arch; + my $elf_support; + my $home_dir; + my $elf_loadobjects_found; + + my $rc_file_paths_ref; + my @rc_file_paths = (); + my $rc_file_errors = 0; + + my @sort_fields = (); + my $summary_metrics; + my $call_metrics; + my $user_metrics; + my $system_metrics; + my $wall_metrics; + my $detail_metrics; + my $detail_metrics_system; + + my $pretty_dir_list; + + my %metric_value = (); + my %metric_description = (); + my %metric_description_reversed = (); + my %metric_found = (); + my %ignored_metrics = (); + + my $metric_value_ref; + my $metric_description_ref; + my $metric_found_ref; + my $ignored_metrics_ref; + + my @table_execution_stats = (); + my $table_execution_stats_ref; + + my $html_first_metric_file_ref; + my $html_first_metric_file; + + my $arch; + my $subexp; + my $linksubexp; + + my $setting_for_LANG; + my $time_percentage_multiplier; + my $process_all_functions; + + my $selected_archive; #------------------------------------------------------------------------------ # If no options are given, print the help info and exit. #------------------------------------------------------------------------------ - $ignore_value = early_scan_specific_options(); + if ($#ARGV == -1) + { + $ignore_value = print_help_info (); + return (0); + } + +#------------------------------------------------------------------------------ +# This part is like a preamble. Before we continue we need to figure out some +# things that are needed later on. +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# 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; + + $ignore_value = early_scan_specific_options (); + +#------------------------------------------------------------------------------ +# 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) + { + gp_message ("debug", $subr_name, "verified the OS commands"); + } + else + { + my $msg = "failure in the verification of the OS commands"; + gp_message ("assertion", $subr_name, $msg); + } + +#------------------------------------------------------------------------------ +# Get the home directory and the locations for the configuration file on the +# current system. +#------------------------------------------------------------------------------ + ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); + + @rc_file_paths = @{ $rc_file_paths_ref }; + gp_message ("debug", $subr_name, "the home directory is $home_dir"); + gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths"); + + $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); + +#------------------------------------------------------------------------------ +# Get the ball rolling. Parse and interpret the configuration file (if any) +# and the command line options. +# +# If either $rc_file_errors or $total_user_errors, or both, are non-zero it +# means a fatal error has occured. In this case, all error messages are +# printed and execution is terminated. +# +# Note that the verbose, debug, and quiet options can be set in this file. +# It is a deliberate choice to ignore these for now. The assumption is that +# the user will not be happy if we ignore the command line settings for a +# while. +#------------------------------------------------------------------------------ + + 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; + + ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options ( + \$#ARGV, + \@ARGV); + $total_user_errors += $option_errors; + +#------------------------------------------------------------------------------ +# 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 ($module_errors > 0) + { + my $msg; + + my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is"; + my @missing_modules = @{ $missing_modules_ref }; + + for my $i (0 .. $#missing_modules) + { + $msg = "module $missing_modules[$i] is missing"; + gp_message ("error", $subr_name, $msg); + } + + $msg = $module_errors . " " . $plural_or_single . + "missing - execution is terminated"; + gp_message ("abort", $subr_name, $msg); + } + +#------------------------------------------------------------------------------ +# The user options have been taken in. Check for validity and consistency. +#------------------------------------------------------------------------------ + gp_message ("verbose", $subr_name, "Process user options"); + + ($option_errors, $ignored_metrics_ref, $outputdir, + $time_percentage_multiplier, $process_all_functions, + $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref); + + @exp_dir_list = @{ $exp_dir_list_ref }; + %ignored_metrics = %{$ignored_metrics_ref}; + + $total_user_errors += $option_errors; + +#------------------------------------------------------------------------------ +# 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"; + } + $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]"); + } + } + +#------------------------------------------------------------------------------ +# Bail out in case fatal errors have occurred. +#------------------------------------------------------------------------------ + 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); + +#------------------------------------------------------------------------------ +# 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); + } + +#------------------------------------------------------------------------------ +# 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); - $ignore_value = be_patient (); +#------------------------------------------------------------------------------------- +# 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 -sub -be_patient +#------------------------------------------------------------------------------ +# Print a message after a failure in $GP_DISPLAY_TEXT. +#------------------------------------------------------------------------------ +sub msg_display_text_failure { - print "Functionality not implemented yet - please stay tuned for updates\n"; + my $subr_name = get_my_name (); + + my ($gp_display_text_cmd, $error_code, $error_file) = @_; -} #-- End of subroutine be_patient + 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 #------------------------------------------------------------------------------ -# Prints the version number and license information. +# 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 -print_version_info +sub append_forward_slash { - 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 $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 print_version_info +} #-- 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 +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 an index.html\n". - "file that can be used to browse the experiment data\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 (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". + " --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. 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". + "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"; + "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); + +#------------------------------------------------------------------------------ #------------------------------------------------------------------------------ -# Scan the command line for specific options. +# Process the data here and generate the HTML lines. #------------------------------------------------------------------------------ -sub -early_scan_specific_options +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# 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 = "early_scan_specific_options"; + 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 $found_option; - my $option_has_value; - my $option_value; - my $verbose_setting = $FALSE; - my $debug_setting = $FALSE; - my $quiet_setting = $FALSE; + 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); - $option_has_value = $FALSE; - ($found_option, $option_value) = find_target_option (\@ARGV, $option_has_value, "--version"); - if ($found_option) + $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')) { - $ignore_value = print_version_info (); - exit(0); + 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}}); } - $option_has_value = $FALSE; - ($found_option, $option_value) = find_target_option (\@ARGV, $option_has_value, "--help"); - if ($found_option) + +#------------------------------------------------------------------------------ +# 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) { - $ignore_value = print_help_info (); - exit(0); + 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 early_scan_specific_options +} #-- 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"); #------------------------------------------------------------------------------ -# Scan the command line to see if the specified option is present. +# 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. # -# Two types of options are supported: options without value (e.g. --help) or -# those that are set to "on" or "off". +# 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"); + } + + #------------------------------------------------------------------------------ -sub -find_target_option +# 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 ($command_line_ref, $has_value, $target_option) = @_; + 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]); - my @command_line = @{ $command_line_ref }; + $number_of_fields = scalar (@my_fields); + gp_message ("debug", $subr_name, "number of fields = $number_of_fields"); + } - my ($command_line_string) = join(" ", @command_line); + 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); + } - my $option_value = "not set"; - my $found_option = $FALSE; +#------------------------------------------------------------------------------ +# 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. +#------------------------------------------------------------------------------ - if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/) + for my $rc_keyword (keys %rc_settings_user) { - if ($has_value) + my $rc_value = $rc_settings_user{$rc_keyword}{"value"}; + + if (exists ( $g_user_settings{$rc_keyword})) { + #------------------------------------------------------------------------------ -# We are looking for this kind if substring: "--verbose on" +# 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? #------------------------------------------------------------------------------ - if (defined($1) and defined($2)) + my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; + + if ($no_of_arguments eq 1) { - if ( ($2 eq "on") or ($2 eq "off") ) + 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. +#------------------------------------------------------------------------------ { - $found_option = $TRUE; - $option_value = $2; + $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); #------------------------------------------------------------------------------ -# We are looking for this kind if substring: "--help" +# Sort the hash keys, the line numbers, alphabetically and print the +# corresponding error messages. #------------------------------------------------------------------------------ - if (defined($1)) + for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} })) { - $found_option = $TRUE; + $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($found_option, $option_value); + return ($parse_errors); -} #-- End of subroutine find_target_option +} #-- 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 |