diff options
Diffstat (limited to 'gprofng')
| -rw-r--r-- | gprofng/gp-display-html/gp-display-html.in | 6967 |
1 files changed, 4147 insertions, 2820 deletions
diff --git a/gprofng/gp-display-html/gp-display-html.in b/gprofng/gp-display-html/gp-display-html.in index dc310f8..4973297 100644 --- a/gprofng/gp-display-html/gp-display-html.in +++ b/gprofng/gp-display-html/gp-display-html.in @@ -18,11 +18,21 @@ # along with this program; if not, write to the Free Software # Foundation, 51 Franklin Street - Fifth Floor, Boston, # MA 02110-1301, USA. - + use strict; use warnings; -use feature qw (state); + +# Disable before release +# use Perl::Critic; + +use bignum; +use List::Util qw (max); +use Cwd qw (abs_path cwd); +use File::Basename; use File::stat; +use feature qw (state); +use POSIX; +use Getopt::Long qw (Configure); #------------------------------------------------------------------------------ # Check as early as possible if the version of Perl used is supported. @@ -64,14 +74,14 @@ my $g_max_length_first_metric; #------------------------------------------------------------------------------ my $g_path_to_tools; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Code debugging flag -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my $g_test_code = $FALSE; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # GPROFNG commands and files used. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my $GP_DISPLAY_TEXT = "gp-display-text"; my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; @@ -92,6 +102,11 @@ my $g_addressing_mode = "64 bit"; my $g_endbr_inst_regex = 'endbr[32|64]'; #------------------------------------------------------------------------------ +# For consistency, use a global variable. +#------------------------------------------------------------------------------ + my $g_html_new_line = "<br>"; + +#------------------------------------------------------------------------------ # These are the regex's used. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ @@ -99,18 +114,10 @@ my $g_addressing_mode = "64 bit"; #------------------------------------------------------------------------------ my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; - my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; - -#------------------------------------------------------------------------------ -# Convenience. These map the on/off value to $TRUE/$FALSE to make the code -# easier to read. For example: "if ($g_verbose)" as opposed to the following: -# "if ($verbose_setting eq "on"). -#------------------------------------------------------------------------------ -my $g_verbose; -my $g_warnings; -my $g_quiet; + my $g_function_call_v2_regex = + '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; -my $g_first_metric; +my $g_first_metric; my $binutils_version; my $driver_cmd; @@ -120,10 +127,23 @@ my $version_info; my %g_mapped_cmds = (); #------------------------------------------------------------------------------ -# TBD All warning messages are collected and are accessible through the main -# page. +# Variables dealing with warnings and errors. Since a message may span +# multiple lines (for readability reasons), the number of entries in the +# array may not reflect the total number of messages. This is why we use +# separate variables for the counts. #------------------------------------------------------------------------------ -my @g_warning_messages = (); +my @g_error_msgs = (); +my @g_warning_msgs = (); +my $g_total_error_count = 0; +#------------------------------------------------------------------------------ +# This count is used in the html_create_warnings_page HTML page to show how +# many warning messages there are. Warnings are printed through gp_message(), +# but since one warning may span multiple lines, we update a separate counter +# that contains the total number of warning messages issued so far. +#------------------------------------------------------------------------------ +my $g_total_warning_count = 0; +my $g_options_printed = $FALSE; +my $g_abort_msg = "cannot recover from the error(s)"; #------------------------------------------------------------------------------ # Contains the names that have already been tagged. This is a global @@ -140,12 +160,10 @@ 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_warn_keyword = "[Warning]"; +my $g_error_keyword = "[Error]"; my %g_function_occurrences = (); my %g_map_function_to_index = (); @@ -155,49 +173,128 @@ my @g_full_function_view_table = (); my @g_html_experiment_stats = (); -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # These structures contain the information printed in the function views. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my $g_header_lines; my @g_html_function_name = (); -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # TBD: This variable may not be needed and replaced by tp_value my $thresh = 0; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Define the driver command, tool name and version number. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ $driver_cmd = "gprofng display html"; $tool_name = "gp-display-html"; #$binutils_version = "2.38.50"; $binutils_version = "BINUTILS_VERSION"; $version_info = $tool_name . " GNU binutils version " . $binutils_version; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ # Define several key data structures. -#------------------------------------------------------------------------------- -my %g_user_settings = +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# This table has the settings of the variables the user may set. +#------------------------------------------------------------------------------ +my %g_user_settings = ( - output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, - overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, - calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, - func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE}, - highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE}, - threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE}, - default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, - ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE}, - verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, - warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE}, - debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE}, - quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, + verbose => { option => "--verbose", + no_of_arguments => 1, + data_type => "onoff", + current_value => "off", defined => $FALSE}, + + debug => { option => "--debug", + no_of_arguments => 1, + data_type => "size", + current_value => "off", defined => $FALSE}, + + warnings => { option => "--warnings", + no_of_arguments => 1, + data_type => "onoff" , + current_value => "off", defined => $FALSE}, + + nowarnings => { option => "--nowarnings", + no_of_arguments => 1, + data_type => "onoff", + current_value => "off", defined => $FALSE}, + + quiet => { option => "--quiet", + no_of_arguments => 1, + data_type => "onoff", + current_value => "off", defined => $FALSE}, + + output => { option => "-o", + no_of_arguments => 1, + data_type => "path", + current_value => undef, defined => $FALSE}, + + overwrite => { option => "-O", + no_of_arguments => 1, + data_type => "path", + current_value => undef, defined => $FALSE}, + + calltree => { option => "-ct", + no_of_arguments => 1, + data_type => "onoff", + current_value => "off", defined => $FALSE}, + + func_limit => { option => "-fl", + no_of_arguments => 1, + data_type => "pinteger", + current_value => 500, defined => $FALSE}, + + highlight_percentage => { option => "--highlight-percentage", + no_of_arguments => 1, + data_type => "pfloat", + current_value => 90.0, defined => $FALSE}, + + hp => { option => "-hp", + no_of_arguments => 1, + data_type => "pfloat", + current_value => 90.0, defined => $FALSE}, + + threshold_percentage => { option => "-tp", + no_of_arguments => 1, + data_type => "pfloat", + current_value => 100.0, defined => $FALSE}, + + default_metrics => { option => "-dm", + no_of_arguments => 1, + data_type => "onoff", + current_value => "off", defined => $FALSE}, + + ignore_metrics => { option => "-im", + no_of_arguments => 1, + data_type => "metric_names", + current_value => undef, defined => $FALSE}, ); -my %g_debug_size = +#------------------------------------------------------------------------------ +# Convenience. These map the on/off value to $TRUE/$FALSE to make the code +# easier to read. For example: "if ($g_verbose)" as opposed to the following: +# "if ($verbose_setting eq "on"). +#------------------------------------------------------------------------------ +my $g_verbose = $FALSE; +my $g_debug = $FALSE; +my $g_warnings = $TRUE; +my $g_quiet = $FALSE; + +#------------------------------------------------------------------------------ +# Since ARGV is modified when parsing the options, a clean copy is used to +# print the original ARGV values in case of a warning, or error. +#------------------------------------------------------------------------------ +my @CopyOfARGV = (); + +my %g_debug_size = ( "on" => $FALSE, "s" => $FALSE, @@ -219,7 +316,10 @@ my %local_system_config = hostname_current => "undefined", ); -# Note that we use single quotes here, because regular expressions wreak havoc otherwise. +#------------------------------------------------------------------------------ +# Note that we use single quotes here, because regular expressions wreak +# havoc otherwise. +#------------------------------------------------------------------------------ my %g_arch_specific_settings = ( @@ -269,7 +369,7 @@ my %g_html_base_file_name = ( ); #------------------------------------------------------------------------------ -# This is cosmetic, but helps with the scoping of variables. +# Introducing main() is cosmetic, but helps with the scoping of variables. #------------------------------------------------------------------------------ main (); @@ -282,6 +382,8 @@ sub main { my $subr_name = get_my_name (); + @CopyOfARGV = @ARGV; + #------------------------------------------------------------------------------ # The name of the configuration file. #------------------------------------------------------------------------------ @@ -289,9 +391,12 @@ sub main #------------------------------------------------------------------------------ # OS commands executed and search paths. +# +# TBD: check if elfdump should be here too (most likely not though) #------------------------------------------------------------------------------ - my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls - uname readelf mkdir); + my @selected_os_cmds = qw (rm cat hostname locale which printenv uname + readelf mkdir); + my @search_paths_os_cmds = qw ( /usr/bin /bin @@ -310,11 +415,11 @@ sub main #------------------------------------------------------------------------------ # Local structures (hashes and arrays). #------------------------------------------------------------------------------ - my @exp_dir_list; # List with experiment directories + my @exp_dir_list = (); my @metrics_data; my %function_address_info = (); - my $function_address_info_ref; + my $function_address_info_ref; my @function_info = (); my $function_info_ref; @@ -340,22 +445,19 @@ sub main #------------------------------------------------------------------------------ # Local variables. #------------------------------------------------------------------------------ - my $abs_path_outputdir; + my $abs_path_outputdir; my $archive_dir_not_empty; - my $base_va_executable; + my $base_va_executable; my $executable_name; - my $exp_dir_list_ref; my $found_exp_dir; my $ignore_value; - my $message; + my $msg; my $number_of_metrics; my $va_executable_in_hex; - my $failed_command_mappings; - my $option_errors; - my $total_user_errors; + my $failed_command_mappings; - my $script_pc_metrics; + my $script_pc_metrics; my $dir_check_errors; my $consistency_errors; my $outputdir; @@ -367,7 +469,7 @@ sub main my $elf_arch; my $elf_support; my $home_dir; - my $elf_loadobjects_found; + my $elf_loadobjects_found; my $rc_file_paths_ref; my @rc_file_paths = (); @@ -380,9 +482,15 @@ sub main my $system_metrics; my $wall_metrics; my $detail_metrics; - my $detail_metrics_system; + my $detail_metrics_system; + + my $html_test; + my @experiment_data; + my $exp_info_file; + my $exp_info_ref; + my @exp_info; - my $pretty_dir_list; + my $pretty_dir_list; my %metric_value = (); my %metric_description = (); @@ -416,12 +524,12 @@ sub main #------------------------------------------------------------------------------ if ($#ARGV == -1) { - $ignore_value = print_help_info (); + $ignore_value = print_help_info (); return (0); } #------------------------------------------------------------------------------ -# This part is like a preamble. Before we continue we need to figure out some +# This part is like a preamble. Before we continue we need to figure out some # things that are needed later on. #------------------------------------------------------------------------------ @@ -431,214 +539,157 @@ sub main my $location_gp_command = $0; #------------------------------------------------------------------------------ -# The very first thing to do is to quickly determine if the user has enabled -# one of the following options and take action accordingly: -# --version, --verbose, --debug, --quiet +# Get the ball rolling. Parse and interpret the options. Some first checks +# are performed. # -# This avoids that there is a gap between the start of the execution and the -# moment the options are parsed, checked, and interpreted. +# Instead of bailing out on the first user error, we capture all warnings and +# errors. The warnings, if any, will be printed once the command line has +# been parsed and verified. Execution continues. # -# When parsing the full command line, these options will be more extensively -# checked and also updated in %g_user_settings - -# Note that a confirmation message, if any, is printed here and not when the -# options are parsed and processed. -#------------------------------------------------------------------------------ - - $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; - $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; - $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; - - $ignore_value = early_scan_specific_options (); - -#------------------------------------------------------------------------------ -# The next subroutine is executed early to ensure the OS commands we need are -# available. +# Any error(s) accumulated in this phase will be printed after the command +# line has been parsed and verified. Execution is then terminated. # -# This subroutine stores the commands and the full path names as an associative -# array called "g_mapped_cmds". The command is the key and the value is the full -# path. For example: ("uname", /usr/bin/uname). +# In the remainder, any error encountered will immediately terminate the +# execution because we can't guarantee the remaining code will work up to +# some point. #------------------------------------------------------------------------------ - $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds); + my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options (); - if ($failed_command_mappings == 0) + $found_exp_dir = ${ $found_exp_dir_ref }; + + if ($found_exp_dir) { - gp_message ("debug", $subr_name, "verified the OS commands"); + @exp_dir_list = @{ $exp_dir_list_ref }; } else { - my $msg = "failure in the verification of the OS commands"; - gp_message ("assertion", $subr_name, $msg); + $msg = "the list with experiments is either missing, or incorrect"; + gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ -# Get the home directory and the locations for the configuration file on the -# current system. -#------------------------------------------------------------------------------ - ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); - - @rc_file_paths = @{ $rc_file_paths_ref }; - gp_message ("debug", $subr_name, "the home directory is $home_dir"); - gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths"); - - $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); - -#------------------------------------------------------------------------------ -# Get the ball rolling. Parse and interpret the configuration file (if any) -# and the command line options. -# -# If either $rc_file_errors or $total_user_errors, or both, are non-zero it -# means a fatal error has occured. In this case, all error messages are -# printed and execution is terminated. -# -# Note that the verbose, debug, and quiet options can be set in this file. -# It is a deliberate choice to ignore these for now. The assumption is that -# the user will not be happy if we ignore the command line settings for a -# while. +# The final settings for verbose, debug, warnings and quiet are known and the +# gp_message() subroutine is aware of these. #------------------------------------------------------------------------------ - - gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now"); - -# Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file"); -# Temporarily disabled -# Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); -# Temporarily disabled -# Temporarily disabled if ($rc_file_errors != 0) -# Temporarily disabled { -# Temporarily disabled $message = "fatal errors in file $rc_file_name encountered"; -# Temporarily disabled gp_message ("debugXL", $subr_name, $message); -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file"); + $msg = "parsing of the user options completed"; + gp_message ("verbose", $subr_name, $msg); #------------------------------------------------------------------------------ -# Get the ball rolling. Parse and interpret the options. Some first checks -# are performed. -# -# Instead of bailing out on the first user error, we capture all errors, print -# messages and then bail out. This is more user friendly. +# The user options have been taken in. Check for validity and consistency. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Parse the user options"); + $msg = "process user options"; + gp_message ("verbose", $subr_name, $msg); - $total_user_errors = 0; + ($ignored_metrics_ref, $outputdir, + $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) = + process_user_options (\@exp_dir_list); - ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options ( - \$#ARGV, - \@ARGV); - $total_user_errors += $option_errors; + @exp_dir_list = @{ $exp_dir_list_ref }; + %ignored_metrics = %{$ignored_metrics_ref}; #------------------------------------------------------------------------------ -# Dynamically load the modules needed. If a module is not available, print -# an error message and bail out. -# -# This call replaces the following: -# -# use feature qw (state); -# use List::Util qw (min max); -# use Cwd; -# use File::Basename; -# use File::stat; -# use POSIX; -# use bignum; +# The next subroutine is executed early to ensure the OS commands we need are +# available. # -# Note that this check cannot be done earlier, because in case of a missing -# module, the man page would not be generated if the code ends prematurely -# in case the --help and --version options are used.. +# This subroutine stores the commands and the full path names as an +# associative array called "g_mapped_cmds". The command is the key and the +# value is the full path. For example: ("uname", /usr/bin/uname). #------------------------------------------------------------------------------ - my ($module_errors_ref, $missing_modules_ref) = handle_module_availability (); - - my $module_errors = ${ $module_errors_ref }; + gp_message ("debug", $subr_name, "verify the OS commands"); + $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, + \@search_paths_os_cmds); - if ($module_errors > 0) + if ($failed_command_mappings == 0) { - my $msg; - - my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is"; - my @missing_modules = @{ $missing_modules_ref }; - - for my $i (0 .. $#missing_modules) - { - $msg = "module $missing_modules[$i] is missing"; - gp_message ("error", $subr_name, $msg); - } - - $msg = $module_errors . " " . $plural_or_single . - "missing - execution is terminated"; - gp_message ("abort", $subr_name, $msg); + $msg = "successfully verified the OS commands"; + gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ -# The user options have been taken in. Check for validity and consistency. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Process user options"); - - ($option_errors, $ignored_metrics_ref, $outputdir, - $time_percentage_multiplier, $process_all_functions, - $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref); - - @exp_dir_list = @{ $exp_dir_list_ref }; - %ignored_metrics = %{$ignored_metrics_ref}; - - $total_user_errors += $option_errors; - +# Time to check if any warnings and/or errors have been generated. #------------------------------------------------------------------------------ -# If no option is given for the output directory, pick a default. Otherwise, -# if the output directory exists, wipe it clean in case the -O option is used. -# If not, flag an error because the -o option does not overwrite an existing -# directory. #------------------------------------------------------------------------------ - if ($total_user_errors == 0) - { - ($option_errors, $outputdir) = set_up_output_directory (); - $abs_path_outputdir = cwd () . "/" . $outputdir; - $total_user_errors += $option_errors; - } - if ($total_user_errors == 0) - { - gp_message ("debug", $subr_name, "the output directory is $outputdir"); - } - else - { #------------------------------------------------------------------------------ -# All command line errors and warnings are printed here. +# We have completed all the upfront checks. Print any warnings and errors. +# If there are already any errors, execution is terminated. As execution +# continues, errors may occur and they are typically fatal. #------------------------------------------------------------------------------ - my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has"; - $message = $g_error_keyword; - $message .= $total_user_errors; - if ($rc_file_errors > 0) - { - $message .= " additional"; - } - $message .= " fatal input $plural_or_single been detected:"; - gp_message ("error", $subr_name, $message); - for my $key (keys @g_user_input_errors) - { - gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]"); - } + if ($g_debug) + { + $msg = "internal settings after option processing"; + $ignore_value = print_table_user_settings ("diag", $msg); } #------------------------------------------------------------------------------ -# Bail out in case fatal errors have occurred. +# Terminate execution in case fatal errors have occurred. #------------------------------------------------------------------------------ - if ( ($rc_file_errors + $total_user_errors) > 0) + if ( $g_total_error_count > 0) { my $msg = "the current values for the user controllable settings"; print_user_settings ("debug", $msg); - gp_message ("abort", $subr_name, "execution terminated"); + gp_message ("abort", $subr_name, $g_abort_msg); } else { my $msg = "after parsing the user options, the final values are"; print_user_settings ("debug", $msg); + } #------------------------------------------------------------------------------ -# TBD: Enable once all planned features have been implemented and tested. +# If no option is given for the output directory, pick a default. Otherwise, +# if the output directory exists, wipe it clean in case the -O option is used. +# If not, raise an error because the -o option does not overwrite an existing +# directory. +# Also in case of other errors, the execution is terminated. #------------------------------------------------------------------------------ -# Temporarily disabled $msg = "the final values for the user controllable settings"; -# Temporarily disabled print_table_user_settings ("verbose", $msg); - } + $outputdir = set_up_output_directory (); + $abs_path_outputdir = Cwd::cwd () . "/" . $outputdir; + + $msg = "the output directory is $outputdir"; + gp_message ("debug", $subr_name, $msg); + +#------------------------------------------------------------------------------ +# Get the home directory and the locations for the configuration file on the +# current system. +#------------------------------------------------------------------------------ + ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); + + @rc_file_paths = @{ $rc_file_paths_ref }; + + $msg = "the home directory is $home_dir"; + gp_message ("debug", $subr_name, $msg); + +#------------------------------------------------------------------------------ +# TBD: de-activated until this feature has been fully implemented. +#------------------------------------------------------------------------------ +## $msg = "the search path for the rc file is @rc_file_paths"; +## gp_message ("debug", $subr_name, $msg); +## $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); + +#------------------------------------------------------------------------------ +# Get the ball rolling. Parse and interpret the configuration file (if any) +# and the command line options. +# +# Note that the verbose, debug, and quiet options can be set in this file. +# It is a deliberate choice to ignore these for now. The assumption is that +# the user will not be happy if we ignore the command line settings for a +# while. +#------------------------------------------------------------------------------ + $msg = "processing of the rc file has been disabled for now"; + gp_message ("debugXL", $subr_name, $msg); + +# Temporarily disabled +# print_table_user_settings ("debugXL", "before function process_rc_file"); +# $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); +# if ($rc_file_errors != 0) +# { +# $message = "fatal errors in file $rc_file_name encountered"; +# gp_message ("debugXL", $subr_name, $message); +# } +# print_table_user_settings ("debugXL", "after function process_rc_file"); #------------------------------------------------------------------------------ # Print a list with the experiment directory names @@ -647,7 +698,8 @@ sub main my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is"; - gp_message ("verbose", $subr_name, "The experiment " . $plural . ":"); + $msg = "the experiment " . $plural . ":"; + gp_message ("verbose", $subr_name, $msg); gp_message ("verbose", $subr_name, $pretty_dir_list); #------------------------------------------------------------------------------ @@ -657,73 +709,77 @@ sub main for my $exp_dir (@exp_dir_list) { my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir); - gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); - gp_message ("debug", $subr_name, "filename = $filename"); - gp_message ("debug", $subr_name, "directory_path = $directory_path"); - $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path; + gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); + gp_message ("debug", $subr_name, "filename = $filename"); + gp_message ("debug", $subr_name, "directory_path = $directory_path"); + $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path; } #------------------------------------------------------------------------------ -# Check whether the experiment directories are valid. If not, it is a fatal -# error. -# Upon successful return, one directory has been selected to be used in the -# remainder. This is not always the correct thing to do, but is the same as -# the original code. In due time this should be addressed though. +# TBD: +# This subroutine may be overkill. See what is really needed here and remove +# everything else. +# +# Upon return, one directory has been selected to be used in the remainder. +# This is not always the correct thing to do, but is the same as the original +# code. In due time this should be addressed though. #------------------------------------------------------------------------------ - ($dir_check_errors, $archive_dir_not_empty, $selected_archive, - $elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref); - - if ($dir_check_errors) - { - gp_message ("abort", $subr_name, "execution terminated"); - } - else - { - gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid"); - } + ($archive_dir_not_empty, $selected_archive, $elf_rats_ref) = + check_validity_exp_dirs (\@exp_dir_list); %elf_rats = %{$elf_rats_ref}; -#------------------------------------------------------------------------------- + $msg = "the experiment directories have been verified and are valid"; + gp_message ("verbose", $subr_name, $msg); + +#------------------------------------------------------------------------------ # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. This includes setting the base virtual address. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ $ignore_value = determine_base_virtual_address ($exp_dir_list_ref); #------------------------------------------------------------------------------ # Check whether the experiment directories are consistent. #------------------------------------------------------------------------------ - ($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref); + ($consistency_errors, $executable_name) = + verify_consistency_experiments ($exp_dir_list_ref); if ($consistency_errors == 0) { - gp_message ("verbose", $subr_name, "The experiment directories are consistent"); + $msg = "the experiment directories are consistent"; + gp_message ("verbose", $subr_name, $msg); } else { - gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors"); + $msg = "the number of consistency errors detected: $consistency_errors"; + gp_message ("abort", $subr_name, $msg); } #------------------------------------------------------------------------------ # The directories are consistent. We can now set the base virtual address of # the executable. #------------------------------------------------------------------------------ - $base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; + $base_va_executable = + $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; - gp_message ("debug", $subr_name, "executable_name = $executable_name"); - gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); - gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable"); + $msg = "executable_name = " . $executable_name; + gp_message ("debug", $subr_name, $msg); + $msg = "selected_archive = " . $selected_archive; + gp_message ("debug", $subr_name, $msg); + $msg = "base_va_executable = " . $base_va_executable; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ -# The $GP_DISPLAY_TEXT tool is critical and has to be available in order -# to proceed. -# This subroutine only returns a value if the tool can be found." +# The $GP_DISPLAY_TEXT tool is critical and has to be available in order to +# proceed. +# This subroutine only returns a value if the tool can be found. #------------------------------------------------------------------------------ $g_path_to_tools = ${ check_availability_tool (\$location_gp_command)}; $GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT; - gp_message ("debug", $subr_name, "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT"); + $msg = "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Check if $GP_DISPLAY_TEXT is executable for user, group, and other. @@ -732,35 +788,38 @@ sub main #------------------------------------------------------------------------------ if (not is_file_executable ($GP_DISPLAY_TEXT)) { - my $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and other"; + $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and"; + $msg .= " other"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Find out what the decimal separator is, as set by the user. #------------------------------------------------------------------------------ - ($return_code, $decimal_separator, $convert_to_dot) = + ($return_code, $decimal_separator, $convert_to_dot) = determine_decimal_separator (); if ($return_code == 0) { - my $txt = "decimal separator is $decimal_separator " . - "(conversion to dot is " . - ($convert_to_dot == $TRUE ? "enabled" : "disabled").")"; - gp_message ("debugXL", $subr_name, $txt); + $msg = "decimal separator is $decimal_separator"; + $msg .= " (conversion to dot is "; + $msg .= ($convert_to_dot == $TRUE ? "enabled" : "disabled") . ")"; + gp_message ("debugXL", $subr_name, $msg); } else { - my $msg = "the decimal separator cannot be determined - set to $decimal_separator"; + $msg = "the decimal separator cannot be determined -"; + $msg .= " set to $decimal_separator"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Collect and store the system information. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Collect system information and adapt settings"); + $msg = "collect system information and adapt settings"; + gp_message ("verbose", $subr_name, $msg); - $return_code = get_system_config_info (); + $return_code = get_system_config_info (); #------------------------------------------------------------------------------ # The 3 variables below are used in the remainder. @@ -775,20 +834,25 @@ sub main gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s"); gp_message ("debug", $subr_name, "set arch_uname = $arch_uname"); -#------------------------------------------------------------------------------- -# This function also sets the values in "g_arch_specific_settings". This +#------------------------------------------------------------------------------ +# This function also sets the values in "g_arch_specific_settings". This # includes several definitions of regular expressions. -#------------------------------------------------------------------------------- - ($architecture_supported, $elf_arch, $elf_support) = - set_system_specific_variables ($arch_uname, $arch_uname_s); +#------------------------------------------------------------------------------ + ($architecture_supported, $elf_arch, $elf_support) = + set_system_specific_variables ($arch_uname, $arch_uname_s); - gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported"); - gp_message ("debug", $subr_name, "elf_arch = $elf_arch"); - gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE")); + $msg = "architecture_supported = $architecture_supported"; + gp_message ("debug", $subr_name, $msg); + $msg = "elf_arch = $elf_arch"; + gp_message ("debug", $subr_name, $msg); + $msg = "elf_support = ".($elf_arch ? "TRUE" : "FALSE"); + gp_message ("debug", $subr_name, $msg); for my $feature (sort keys %g_arch_specific_settings) { - gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}"); + $msg = "g_arch_specific_settings{$feature} = "; + $msg .= $g_arch_specific_settings{$feature}; + gp_message ("debug", $subr_name, $msg); } $arch = $g_arch_specific_settings{"arch"}; @@ -797,7 +861,8 @@ sub main $g_locale_settings{"LANG"} = get_LANG_setting (); - gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"); + $msg = "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"; + gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Temporarily reset selected settings since these are not yet implemented. @@ -808,19 +873,28 @@ sub main # TBD: Revisit. Is this really necessary? #------------------------------------------------------------------------------ - ($executable_name, $va_executable_in_hex) = check_loadobjects_are_elf ($selected_archive); + ($executable_name, $va_executable_in_hex) = + check_loadobjects_are_elf ($selected_archive); $elf_loadobjects_found = $TRUE; # TBD: Hack and those ARCHIVES_ names can be eliminated $ARCHIVES_MAP_NAME = $executable_name; $ARCHIVES_MAP_VADDR = $va_executable_in_hex; - gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); - gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); - gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found"); - + $msg = "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"; + gp_message ("debugXL", $subr_name, $msg); + $msg = "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"; + gp_message ("debugXL", $subr_name, $msg); + + $msg = "after call to check_loadobjects_are_elf forced"; + $msg .= " elf_loadobjects_found = $elf_loadobjects_found"; + gp_message ("debugXL", $subr_name, $msg); + $g_html_credits_line = ${ create_html_credits () }; - gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line"); + + $msg = "g_html_credits_line = $g_html_credits_line"; + gp_message ("debugXL", $subr_name, $msg); + #------------------------------------------------------------------------------ # Add a "/" to simplify the construction of path names in the remainder. # @@ -841,7 +915,7 @@ sub main $detail_metrics_system = 'e.totalcpu:e.system'; $call_metrics = 'a.totalcpu'; - my $cmd_options; + my $cmd_options; my $metrics_cmd; my $outfile1 = $outputdir ."metrics"; @@ -853,9 +927,11 @@ sub main # to get all the output in files $outfile1 and $outfile2. These are then # parsed. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments"); + $msg = "gather the metrics data from the experiments"; + gp_message ("verbose", $subr_name, $msg); - $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file); + $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, + $outfile2, $gp_error_file); if ($return_code != 0) { @@ -865,8 +941,11 @@ sub main #------------------------------------------------------------------------------ # TBD: Test this code #------------------------------------------------------------------------------ - open (METRICS, "<", $outfile1) - or die ("$subr_name - unable to open metric value data file $outfile1 for reading: '$!'"); + $msg = "unable to open metric value data file $outfile1 for reading:"; + open (METRICS, "<", $outfile1) + or die ($subr_name . " - " . $msg . " " . $!); + + $msg = "opened file $outfile1 for reading"; gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); chomp (@metrics_data = <METRICS>); @@ -874,7 +953,8 @@ sub main for my $i (keys @metrics_data) { - gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]"); + $msg = "metrics_data[$i] = " . $metrics_data[$i]; + gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -888,7 +968,7 @@ sub main { gp_message ("verbose", $subr_name, "Process the metrics data"); - ($metric_value_ref, $metric_description_ref, $metric_found_ref, + ($metric_value_ref, $metric_description_ref, $metric_found_ref, $user_metrics, $system_metrics, $wall_metrics, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics ) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics); @@ -898,14 +978,19 @@ sub main %metric_found = %{ $metric_found_ref }; %metric_description_reversed = reverse %metric_description; - gp_message ("debugXL", $subr_name, "after the call to process_metrics_data"); + $msg = "after the call to process_metrics_data"; + gp_message ("debugXL", $subr_name, $msg); + for my $metric (sort keys %metric_value) { - gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}"); + $msg = "metric_value{$metric} = " . $metric_value{$metric}; + gp_message ("debugXL", $subr_name, $msg); } for my $metric (sort keys %metric_description) { - gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}"); + $msg = "metric_description{$metric} ="; + $msg .= " " . $metric_description{$metric}; + gp_message ("debugXL", $subr_name, $msg); } gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics"); gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics"); @@ -918,9 +1003,10 @@ sub main # # TBD: These should be OS dependent. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Select the set of default metrics"); + $msg = "select the set of default metrics"; + gp_message ("verbose", $subr_name, $msg); - ($metric_description_ref, $metric_found_ref, $summary_metrics, + ($metric_description_ref, $metric_found_ref, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics ) = set_default_metrics ($outfile1, \%ignored_metrics); @@ -929,51 +1015,54 @@ sub main %metric_found = %{ $metric_found_ref }; %metric_description_reversed = reverse %metric_description; - gp_message ("debug", $subr_name, "after the call to set_default_metrics"); + $msg = "after the call to set_default_metrics"; + gp_message ("debug", $subr_name, $msg); } $number_of_metrics = split (":", $summary_metrics); - gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics"); - gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics"); - gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system"); - gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics"); - gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics"); + $msg = "summary_metrics = " . $summary_metrics; + gp_message ("debugXL", $subr_name, $msg); + $msg = "detail_metrics = " . $detail_metrics; + gp_message ("debugXL", $subr_name, $msg); + $msg = "detail_metrics_system = " . $detail_metrics_system; + gp_message ("debugXL", $subr_name, $msg); + $msg = "call_metrics = " . $call_metrics; + gp_message ("debugXL", $subr_name, $msg); + $msg = "number_of_metrics = " . $number_of_metrics; + gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # TBD Find a way to better handle this situation: #------------------------------------------------------------------------------ for my $im (keys %metric_found) { - gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}"); + $msg = "metric_found{$im} = " . $metric_found{$im}; + gp_message ("debugXL", $subr_name, $msg); } for my $im (keys %ignored_metrics) { if (not exists ($metric_found{$im})) { - gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics"); + $msg = "user requested ignored metric (-im) $im does not exist in"; + $msg .= " collected metrics"; + gp_message ("debugXL", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Get the information on the experiments. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Generate the experiment information"); - - my $exp_info_file_ref; - my $exp_info_file; - my $exp_info_ref; - my @exp_info; - - my $experiment_data_ref; + $msg = "generate the experiment information"; + gp_message ("verbose", $subr_name, $msg); - $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); - my @experiment_data = @{ $experiment_data_ref }; + my $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); + @experiment_data = @{ $experiment_data_ref }; for my $i (sort keys @experiment_data) { - my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . + my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . $experiment_data[$i]{"exp_name_full"}; gp_message ("debugM", $subr_name, $msg); } @@ -991,21 +1080,21 @@ sub main } } - @g_html_experiment_stats = @{ create_exp_info ( - \@exp_dir_list, - \@experiment_data) }; + @g_html_experiment_stats = @{ create_exp_info (\@exp_dir_list, + \@experiment_data) }; - $table_execution_stats_ref = html_generate_exp_summary ( - \$outputdir, - \@experiment_data); + $table_execution_stats_ref = html_generate_exp_summary (\$outputdir, + \@experiment_data); @table_execution_stats = @{ $table_execution_stats_ref }; #------------------------------------------------------------------------------ # Get the function overview. #------------------------------------------------------------------------------ - gp_message ("verbose", $subr_name, "Generate the list with functions executed"); + $msg = "generate the list with functions executed"; + gp_message ("verbose", $subr_name, $msg); - my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); + my ($outfile, $sort_fields_ref) = + get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); @sort_fields = @{$sort_fields_ref}; @@ -1013,11 +1102,12 @@ sub main # Parse the output from the fsummary command and store the relevant data for # all the functions listed there. #------------------------------------------------------------------------------ + $msg = "analyze and store the relevant function information"; + gp_message ("verbose", $subr_name, $msg); - gp_message ("verbose", $subr_name, "Analyze and store the relevant function information"); - - ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref, - $LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile); + ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref, + $LINUX_vDSO_ref, $function_view_structure_ref) = + get_function_info ($outfile); @function_info = @{ $function_info_ref }; %function_address_and_index = %{ $function_address_and_index_ref }; @@ -1029,194 +1119,215 @@ sub main { for my $fields (keys %{$function_info[$keys]}) { - gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}"); + $msg = "$keys $fields $function_info[$keys]{$fields}"; + gp_message ("debugXL", $subr_name, $msg); } } for my $i (keys %addressobjtextm) { - gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}"); + $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i}; + gp_message ("debugXL", $subr_name, $msg); } - gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information"); + $msg = "generate the files with function overviews and the"; + $msg .= " callers-callees information"; + gp_message ("verbose", $subr_name, $msg); - $script_pc_metrics = generate_function_level_info (\@exp_dir_list, - $call_metrics, - $summary_metrics, - $outputdir, + $script_pc_metrics = generate_function_level_info (\@exp_dir_list, + $call_metrics, + $summary_metrics, + $outputdir, $sort_fields_ref); - gp_message ("verbose", $subr_name, "Preprocess the files with the function level information"); + $msg = "preprocess the files with the function level information"; + gp_message ("verbose", $subr_name, $msg); $ignore_value = preprocess_function_files ( - $metric_description_ref, - $script_pc_metrics, - $outputdir, + $metric_description_ref, + $script_pc_metrics, + $outputdir, \@sort_fields); - gp_message ("verbose", $subr_name, "For each function, generate a set of files"); - - ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files ( - \@exp_dir_list, - $executable_name, - $time_percentage_multiplier, - $summary_metrics, - $process_all_functions, - $elf_loadobjects_found, - $outputdir, - \@sort_fields, - \@function_info, - \%function_address_and_index, - \%LINUX_vDSO, - \%metric_description, - $elf_arch, - $base_va_executable, - $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats); + $msg = "for each function, generate a set of files"; + gp_message ("verbose", $subr_name, $msg); + + ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = + process_function_files (\@exp_dir_list, + $executable_name, + $time_percentage_multiplier, + $summary_metrics, + $process_all_functions, + $elf_loadobjects_found, + $outputdir, + \@sort_fields, + \@function_info, + \%function_address_and_index, + \%LINUX_vDSO, + \%metric_description, + $elf_arch, + $base_va_executable, + $ARCHIVES_MAP_NAME, + $ARCHIVES_MAP_VADDR, + \%elf_rats); @function_info = @{ $function_info_ref }; %function_address_info = %{ $function_address_info_ref }; %addressobj_index = %{ $addressobj_index_ref }; -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Parse the disassembly information and generate the html files. -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files"); +#------------------------------------------------------------------------------ + $msg = "parse the disassembly files and generate the html files"; + gp_message ("verbose", $subr_name, $msg); - $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info, - \%function_address_and_index, - \$outputdir, \%addressobj_index); + $ignore_value = parse_dis_files (\$number_of_metrics, + \@function_info, + \%function_address_and_index, + \$outputdir, + \%addressobj_index); -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Parse the source information and generate the html files. -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Parse the source files and generate the html files"); +#------------------------------------------------------------------------------ + $msg = "parse the source files and generate the html files"; + gp_message ("verbose", $subr_name, $msg); parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Parse the caller-callee information and generate the html files. -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file"); +#------------------------------------------------------------------------------ + $msg = "process the caller-callee information and generate the html file"; + gp_message ("verbose", $subr_name, $msg); -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Generate the caller-callee information. -#------------------------------------------------------------------------------------- - $ignore_value = generate_caller_callee ( - \$number_of_metrics, - \@function_info, - \%function_view_structure, - \%function_address_info, - \%addressobjtextm, - \$outputdir); - -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ + $ignore_value = generate_caller_callee (\$number_of_metrics, + \@function_info, + \%function_view_structure, + \%function_address_info, + \%addressobjtextm, + \$outputdir); + +#------------------------------------------------------------------------------ # Parse the calltree information and generate the html files. -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if ($g_user_settings{"calltree"}{"current_value"} eq "on") { - my $msg = "Process the call tree information and generate the html file"; + $msg = "process the call tree information and generate the html file"; gp_message ("verbose", $subr_name, $msg); - $ignore_value = process_calltree ( - \@function_info, - \%function_address_info, - \%addressobjtextm, - $outputdir); + $ignore_value = process_calltree (\@function_info, + \%function_address_info, + \%addressobjtextm, + $outputdir); } -#------------------------------------------------------------------------------------- -# TBD -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Generate the html file with the metrics information"); +#------------------------------------------------------------------------------ +# Process the metric values. +#------------------------------------------------------------------------------ + $msg = "generate the html file with the metrics information"; + gp_message ("verbose", $subr_name, $msg); - $ignore_value = process_metrics ( - $outputdir, - \@sort_fields, - \%metric_description, - \%ignored_metrics); + $ignore_value = process_metrics ($outputdir, + \@sort_fields, + \%metric_description, + \%ignored_metrics); -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Generate the function view html files. -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Generate the function view html files"); +#------------------------------------------------------------------------------ + $msg = "generate the function view html files"; + gp_message ("verbose", $subr_name, $msg); $html_first_metric_file_ref = generate_function_view ( - \$outputdir, - \$summary_metrics, - \$number_of_metrics, - \@function_info, - \%function_view_structure, - \%function_address_info, - \@sort_fields, - \@exp_dir_list, - \%addressobjtextm); + \$outputdir, + \$summary_metrics, + \$number_of_metrics, + \@function_info, + \%function_view_structure, + \%function_address_info, + \@sort_fields, + \@exp_dir_list, + \%addressobjtextm); $html_first_metric_file = ${ $html_first_metric_file_ref }; - gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file"); + $msg = "html_first_metric_file = " . $html_first_metric_file; + gp_message ("debugXL", $subr_name, $msg); - my $html_test = ${ generate_home_link ("left") }; - gp_message ("debugXL", $subr_name, "html_test = $html_test"); + $html_test = ${ generate_home_link ("left") }; + $msg = "html_test = " . $html_test; + gp_message ("debugXL", $subr_name, $msg); - my $number_of_warnings_ref = create_html_warnings_page (\$outputdir); +#------------------------------------------------------------------------------ +# Unconditionnaly generate the page with the warnings. +#------------------------------------------------------------------------------ + $ignore_value = html_create_warnings_page (\$outputdir); -#------------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Generate the index.html file. -#------------------------------------------------------------------------------------- - gp_message ("verbose", $subr_name, "Generate the index.html file"); - - $ignore_value = generate_index (\$outputdir, - \$html_first_metric_file, - \$summary_metrics, - \$number_of_metrics, - \@function_info, - \%function_address_info, - \@sort_fields, - \@exp_dir_list, - \%addressobjtextm, - \%metric_description_reversed, - $number_of_warnings_ref, - \@table_execution_stats); - -#------------------------------------------------------------------------------------- -# We're done. In debug mode, print the meta data for the experiment directories. -#------------------------------------------------------------------------------------- - $ignore_value = print_meta_data_experiments ("debug"); - - my $results_file = $abs_path_outputdir . "/index.html"; - my $prologue_text = "Processing completed - view file $results_file in a browser"; - gp_message ("diag", $subr_name, $prologue_text); - - return (0); +#------------------------------------------------------------------------------ + $msg = "generate the index.html file"; + gp_message ("verbose", $subr_name, $msg); -} #-- End of subroutine main + $ignore_value = html_generate_index (\$outputdir, + \$html_first_metric_file, + \$summary_metrics, + \$number_of_metrics, + \@function_info, + \%function_address_info, + \@sort_fields, + \@exp_dir_list, + \%addressobjtextm, + \%metric_description_reversed, + \@table_execution_stats); #------------------------------------------------------------------------------ -# Print a message after a failure in $GP_DISPLAY_TEXT. +# We're done. In debug mode, print the meta data for the experiment +# directories. #------------------------------------------------------------------------------ -sub msg_display_text_failure -{ - my $subr_name = get_my_name (); - - my ($gp_display_text_cmd, $error_code, $error_file) = @_; - - my $msg; + $ignore_value = print_meta_data_experiments ("debug"); - $msg = "error code = $error_code - failure executing the following command:"; - gp_message ("error", $subr_name, $msg); +#------------------------------------------------------------------------------ +# Before the execution completes, print the warning(s) on the screen. +# +# Note that this assumes that no additional warnings have been created since +# the call to html_create_warnings_page. Otherwise there will be a discrepancy +# between what is printed on the screen and shown in the warnings.html page. +#------------------------------------------------------------------------------ + if (($g_total_warning_count > 0) and ($g_warnings)) + { + $ignore_value = print_warnings_buffer (); + @g_warning_msgs = (); + } - gp_message ("error", $subr_name, $gp_display_text_cmd); +#------------------------------------------------------------------------------ +# This is not supposed to happen, but in case there are any fatal errors that +# have not caused the execution to terminate, print them here. +#------------------------------------------------------------------------------ + if (@g_error_msgs) + { + $ignore_value = print_errors_buffer (\$g_error_keyword); + } - $msg = "check file $error_file for more details"; - gp_message ("error", $subr_name, $msg); +#------------------------------------------------------------------------------ +# One line message to show where the results can be found. +#------------------------------------------------------------------------------ + my $results_file = $abs_path_outputdir . "/index.html"; + my $prologue_text = "Processing completed - view file $results_file" . + " in a browser"; + gp_message ("diag", $subr_name, $prologue_text); return (0); -} #-- End of subroutine msg_display_text_failure +} #-- End of subroutine main #------------------------------------------------------------------------------ # If it is not present, add a "/" to the name of the argument. This is -# intended to be used for the name of the output directory and makes it +# intended to be used for the name of the output directory and makes it # easier to construct pathnames. #------------------------------------------------------------------------------ sub append_forward_slash @@ -1228,7 +1339,7 @@ sub append_forward_slash my $length_of_string = length ($input_string); my $return_string = $input_string; - if (rindex ($input_string, "/") != $length_of_string-1) + if (rindex ($input_string, "/") != $length_of_string-1) { $return_string .= "/"; } @@ -1255,7 +1366,7 @@ sub build_pretty_dir_list } #-- End of subroutine build_pretty_dir_list #------------------------------------------------------------------------------ -# Calculate the target address in hex by adding the instruction to the +# Calculate the target address in hex by adding the instruction to the # instruction address. #------------------------------------------------------------------------------ sub calculate_target_hex_address @@ -1264,14 +1375,15 @@ sub calculate_target_hex_address my ($instruction_address, $instruction_offset) = @_; - my $dec_branch_target; + my $dec_branch_target; my $d1; my $d2; my $first_char; my $length_of_string; my $mask; + my $msg; my $number_of_fields; - my $raw_hex_branch_target; + my $raw_hex_branch_target; my $result; if ($g_addressing_mode eq "64 bit") @@ -1281,10 +1393,11 @@ sub calculate_target_hex_address } else { - gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n"); + $msg = "g_addressing_mode = $g_addressing_mode not supported"; + gp_message ("abort", $subr_name, $msg); } - - $length_of_string = length ($instruction_offset); + + $length_of_string = length ($instruction_offset); $first_char = lcfirst (substr ($instruction_offset,0,1)); $d1 = bigint::hex ($instruction_offset); $d2 = bigint::hex ($mask); @@ -1315,11 +1428,15 @@ sub calculate_target_hex_address } #-- End of subroutine calculate_target_hex_address #------------------------------------------------------------------------------ -# Sets the absolute path to all commands in array @cmds. The commands and -# their respective paths are stored in hash "g_mapped_cmds". +# Sets the absolute path to all commands in array @cmds. +# +# First, it is checked if the command is in the search path, built-in, or an +# alias. If this is not the case, search for it in a couple of locations. # -# If no such mapping is found, a warning is issued, but execution continues. -# The warning(s) may help with troubleshooting, should a failure occur later. +# If this all fails, warning messages are printed, but this is not a hard +# error. Yet. Most likely, things will go bad later on. +# +# The commands and their respective paths are stored in hash "g_mapped_cmds". #------------------------------------------------------------------------------ sub check_and_define_cmds { @@ -1333,37 +1450,129 @@ sub check_and_define_cmds my @cmds = @{$cmds_ref}; my @search_path = @{$search_path_ref}; - my $found_match; - my $target_cmd; - my $failed_cmd; - my $no_of_failed_mappings; + my @the_fields = (); + + my $cmd; + my $cmd_found; + my $error_code; + my $failed_cmd; my $failed_cmds; + my $found_match; + my $mapped; + my $msg; + my $no_of_failed_mappings; + my $no_of_fields; + my $output_cmd; + my $target_cmd; + my $failed_mapping = $FALSE; + my $full_path_cmd; - gp_message ("debug", $subr_name, "\@cmds = @cmds"); - gp_message ("debug", $subr_name, "\@search_path = @search_path"); + gp_message ("debugXL", $subr_name, "\@cmds = @cmds"); + gp_message ("debugXL", $subr_name, "\@search_path = @search_path"); #------------------------------------------------------------------------------ -# Search for the command to be in the search path given. In case no such path +# Search for the command and record the absolute path. In case no such path # can be found, the entry in $g_mapped_cmds is assigned a special value that # will be checked for in the next block. #------------------------------------------------------------------------------ - for my $cmd (@cmds) + for $cmd (@cmds) { - $found_match = $FALSE; - for my $path (@search_path) + $target_cmd = "(command -v $cmd; echo \$\?)"; + + ($error_code, $output_cmd) = execute_system_cmd ($target_cmd); + + if ($error_code != 0) +#------------------------------------------------------------------------------ +# This is unlikely to happen, since it means the command executed failed. +#------------------------------------------------------------------------------ + { + $msg = "error executing this command: " . $target_cmd; + gp_message ("warning", $subr_name, $msg); + $msg = "execution continues, but may fail later on"; + gp_message ("warning", $subr_name, $msg); + + $g_total_warning_count++; + } + else +#------------------------------------------------------------------------------ +# So far, all is well, but is the target command available? +#------------------------------------------------------------------------------ { - $target_cmd = $path . "/" . $cmd; - if (-x $target_cmd) +#------------------------------------------------------------------------------ +# The output from the $target_cmd command should contain 2 lines in case the +# command has been found. The first line shows the command with the full +# path, while the second line has the exit code. +# +# If the exit code is not zero, the command has not been found. +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# Split the output at the \n character and check the number of lines as +# well as the return code. +#------------------------------------------------------------------------------ + @the_fields = split ("\n", $output_cmd); + $no_of_fields = scalar (@the_fields); + $cmd_found = ($the_fields[$no_of_fields-1] == 0 ? $TRUE : $FALSE); + +#------------------------------------------------------------------------------ +# This is unexpected. Throw an assertion error and bail out. +#------------------------------------------------------------------------------ + if ($no_of_fields > 2) { - $found_match = $TRUE; - $g_mapped_cmds{$cmd} = $target_cmd; - last; + gp_message ("error", $subr_name, "output from $target_cmd:"); + gp_message ("error", $subr_name, $output_cmd); + + $msg = "the output from $target_cmd has more than 2 lines"; + gp_message ("assertion", $subr_name, $msg); } - } - if (not $found_match) - { - $g_mapped_cmds{$cmd} = "road_to_nowhere"; + if ($cmd_found) + { + $full_path_cmd = $the_fields[0]; +#------------------------------------------------------------------------------ +# The command is in the search path. Store the full path to the command. +#------------------------------------------------------------------------------ + $msg = "the $cmd command is in the search path"; + gp_message ("debug", $subr_name, $msg); + + $g_mapped_cmds{$cmd} = $full_path_cmd; + } + else +#------------------------------------------------------------------------------ +# A best effort to locate the command elsewhere. If found, store the command +# with the absolute path included. Otherwise print a warning, but continue. +#------------------------------------------------------------------------------ + { + $msg = "the $cmd command is not in the search path"; + $msg .= " - start a best effort search to find it"; + gp_message ("debug", $subr_name, $msg); + + $found_match = $FALSE; + for my $path (@search_path) + { + $target_cmd = $path . "/" . $cmd; + if (-x $target_cmd) + { + $msg = "found the command in $path"; + gp_message ("debug", $subr_name, $msg); + + $found_match = $TRUE; + $g_mapped_cmds{$cmd} = $target_cmd; + last; + } + else + { + $msg = "failure to find the $cmd command in $path"; + gp_message ("debug", $subr_name, $msg); + } + } + + if (not $found_match) + { + $g_mapped_cmds{$cmd} = "road to nowhere"; + $failed_mapping = $TRUE; + } + } } } @@ -1372,26 +1581,50 @@ sub check_and_define_cmds #------------------------------------------------------------------------------ $no_of_failed_mappings = 0; $failed_cmds = ""; - while ( my ($cmd, $mapped) = each %g_mapped_cmds) + +#------------------------------------------------------------------------------ +# Print a warning message before showing the results, that at least one search +# has failed. +#------------------------------------------------------------------------------ + if ($failed_mapping) + { + $msg = "<br>" . "failure in the verification of the OS commands:"; + gp_message ("warning", $subr_name, $msg); + } + + while ( ($cmd, $mapped) = each %g_mapped_cmds) { - if ($mapped eq "road_to_nowhere") + if ($mapped eq "road to nowhere") { - my $msg = "cannot find a path for command $cmd - " . - "assume this will still work without a path"; + $msg = "cannot find a path for command $cmd"; gp_message ("warning", $subr_name, $msg); - $no_of_failed_mappings++; - $failed_cmds .= $cmd; + gp_message ("debug", $subr_name, $msg); + + $no_of_failed_mappings++; + $failed_cmds .= $cmd; $g_mapped_cmds{$cmd} = $cmd; } else { - gp_message ("debug", $subr_name, "path for the $cmd command is $mapped"); + $msg = "path for the $cmd command is $mapped"; + gp_message ("debug", $subr_name, $msg); } } if ($no_of_failed_mappings != 0) { - gp_message ("debug", $subr_name, "failed to find a mapping for $failed_cmds"); - gp_message ("debug", $subr_name, "a total of $no_of_failed_mappings mapping failures"); + my $plural_1 = ($no_of_failed_mappings > 1) ? "failures" : "failure"; + my $plural_2 = ($no_of_failed_mappings > 1) ? "commands" : "command"; + + $msg = "encountered $no_of_failed_mappings $plural_1 to locate"; + $msg .= " selected " . $plural_2; + gp_message ("warning", $subr_name, $msg); + gp_message ("debug", $subr_name, $msg); + + $msg = "execution continues, but may fail later on"; + gp_message ("warning", $subr_name, $msg); + gp_message ("debug", $subr_name, $msg); + + $g_total_warning_count++; } return ($no_of_failed_mappings); @@ -1423,7 +1656,7 @@ sub check_and_proc_dis_branches my $msg; my $raw_hex_branch_target; - if ( ($input_line =~ /$g_branch_regex/) + if ( ($input_line =~ /$g_branch_regex/) or ($input_line =~ /$g_endbr_regex/)) { if (defined ($3)) @@ -1451,12 +1684,13 @@ sub check_and_proc_dis_branches #------------------------------------------------------------------------------ $instruction_offset = $3; $raw_hex_branch_target = calculate_target_hex_address ( - $instruction_address, - $instruction_offset); + $instruction_address, + $instruction_offset); $hex_branch_target = "0x" . $raw_hex_branch_target; $branch_target{$hex_branch_target} = 1; - $extended_branch_target{$instruction_address} = $raw_hex_branch_target; + $extended_branch_target{$instruction_address} = + $raw_hex_branch_target; } if (defined ($2) and (not defined ($3))) { @@ -1482,7 +1716,8 @@ sub check_and_proc_dis_branches # TBD: Perhaps this should be an assertion or alike. #------------------------------------------------------------------------------ $branch_target{"0x0000"} = $FALSE; - gp_message ("debug", $subr_name, "cannot determine branch target"); + $msg = "cannot determine branch target"; + gp_message ("debug", $subr_name, $msg); } } else @@ -1512,11 +1747,11 @@ sub check_and_proc_dis_func_call my %extended_branch_target = %{ $extended_branch_target_ref }; my $found_it = $TRUE; - my $hex_branch_target; + my $hex_branch_target; my $instruction_address; my $instruction_offset; my $msg; - my $raw_hex_branch_target; + my $raw_hex_branch_target; if ( $input_line =~ /$g_function_call_v2_regex/ ) { @@ -1558,8 +1793,8 @@ sub check_and_proc_dis_func_call # address. #------------------------------------------------------------------------------ $raw_hex_branch_target = calculate_target_hex_address ( - $instruction_address, - $instruction_offset); + $instruction_address, + $instruction_offset); $hex_branch_target = "0x" . $raw_hex_branch_target; $msg = "calculated hex_branch_target = " . @@ -1567,12 +1802,13 @@ sub check_and_proc_dis_func_call gp_message ("debugXL", $subr_name, $msg); $branch_target{$hex_branch_target} = 1; - $extended_branch_target{$instruction_address} = $raw_hex_branch_target; + $extended_branch_target{$instruction_address} = + $raw_hex_branch_target; $msg = "set branch_target{$hex_branch_target} to 1"; gp_message ("debugXL", $subr_name, $msg); - $msg = "added extended_branch_target{$instruction_address}" . - " = $extended_branch_target{$instruction_address}"; + $msg = "added extended_branch_target{$instruction_address}"; + $msg .= " = $extended_branch_target{$instruction_address}"; gp_message ("debugXL", $subr_name, $msg); } else @@ -1593,11 +1829,77 @@ sub check_and_proc_dis_func_call } #-- End of subroutine check_and_proc_dis_func_call #------------------------------------------------------------------------------ -# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool -# needed to provide the information. If it can not be found, execution is +# Check if the value for the user option given is valid. +# +# In case the value is valid, the g_user_settings table is updated with the +# (new) value. +# +# Otherwise an error message is pushed into the g_error_msgs buffer. +# +# The return value is TRUE/FALSE. +#------------------------------------------------------------------------------ +sub check_and_set_user_option +{ + my $subr_name = get_my_name (); + + my ($internal_opt_name, $value) = @_; + + my $msg; + my $valid; + my $option_value_missing; + + my $option = $g_user_settings{$internal_opt_name}{"option"}; + my $data_type = $g_user_settings{$internal_opt_name}{"data_type"}; + my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"}; + + if (($no_of_args >= 1) and + ((not defined ($value)) or (length ($value) == 0))) +#------------------------------------------------------------------------------ +# If there was no value given, but it is required, flag an error. +# There could also be a value, but it might be the empty string. +# +# Note that that there are currently no options with multiple values. Should +# these be introduced, the current check may need to be refined. +#------------------------------------------------------------------------------ + { + $valid = $FALSE; + $option_value_missing = $TRUE; + } + elsif ($no_of_args >= 1) + { + $option_value_missing = $FALSE; +#------------------------------------------------------------------------------ +# There is an input value. Check if it is valid and if so, store it. +# +# Note that we allow the options to be case insensitive. +#------------------------------------------------------------------------------ + $valid = verify_if_input_is_valid ($value, $data_type); + + if ($valid) + { + if (($data_type eq "onoff") or ($data_type eq "size")) + { + $g_user_settings{$internal_opt_name}{"current_value"} = + lc ($value); + } + else + { + $g_user_settings{$internal_opt_name}{"current_value"} = $value; + } + $g_user_settings{$internal_opt_name}{"defined"} = $TRUE; + } + } + + return (\$valid, \$option_value_missing); + +} #-- End of subroutine check_and_set_user_option + +#------------------------------------------------------------------------------ +# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool +# needed to provide the information. If it can not be found, execution is # terminated. # -# We first search foe this tool in the current execution directory. If it +# We first search for this tool in the current execution directory. If it # cannot be found there, use $PATH to try to locate it. #------------------------------------------------------------------------------ sub check_availability_tool @@ -1608,6 +1910,7 @@ sub check_availability_tool my $error_code; my $error_occurred; + my $gp_path; my $msg; my $output_which_gp_display_text; my $return_value; @@ -1616,23 +1919,24 @@ sub check_availability_tool #------------------------------------------------------------------------------ # Get the path to gp-display-text. #------------------------------------------------------------------------------ - my ($error_occurred_ref, $return_value_ref) = find_path_to_gp_display_text ( - $location_gp_command_ref - ); - $error_occurred = ${ $error_occurred_ref}; + my ($error_occurred_ref, $gp_path_ref, $return_value_ref) = + find_path_to_gp_display_text ($location_gp_command_ref); + + $error_occurred = ${ $error_occurred_ref}; + $gp_path = ${ $gp_path_ref }; $return_value = ${ $return_value_ref}; $msg = "error_occurred = $error_occurred return_value = $return_value"; gp_message ("debugXL", $subr_name, $msg); - if (not $error_occurred) + if (not $error_occurred) #------------------------------------------------------------------------------ # All is well and gp-display-text has been located. #------------------------------------------------------------------------------ { $g_path_to_tools = $return_value; - $msg = "located $GP_DISPLAY_TEXT in execution directory"; + $msg = "located $GP_DISPLAY_TEXT in the execution directory"; gp_message ("debug", $subr_name, $msg); $msg = "g_path_to_tools = $g_path_to_tools"; gp_message ("debug", $subr_name, $msg); @@ -1643,42 +1947,49 @@ sub check_availability_tool # $GP_DISPLAY_TEXT through the search path. #------------------------------------------------------------------------------ { - $msg = "error accessing $GP_DISPLAY_TEXT: $return_value - " . - "run time behaviour may be undefined"; + $msg = $g_html_new_line; + $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :"; + $msg .= " $return_value"; gp_message ("warning", $subr_name, $msg); - + #------------------------------------------------------------------------------ # Check if we can find $GP_DISPLAY_TEXT in the search path. #------------------------------------------------------------------------------ - $msg = "check for $GP_DISPLAY_TEXT in search path"; + $msg = "check for $GP_DISPLAY_TEXT to be in the search path"; gp_message ("debug", $subr_name, $msg); + gp_message ("warning", $subr_name, $msg); + $g_total_warning_count++; + $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; - ($error_code, $output_which_gp_display_text) = - execute_system_cmd ($target_cmd); - + ($error_code, $output_which_gp_display_text) = + execute_system_cmd ($target_cmd); + if ($error_code == 0) { - my ($gp_file_name, $gp_path, $suffix_not_used) = + my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($output_which_gp_display_text); $g_path_to_tools = $gp_path; - $msg = "using $GP_DISPLAY_TEXT in $g_path_to_tools instead"; + $msg = "located $GP_DISPLAY_TEXT in $g_path_to_tools"; + gp_message ("warning", $subr_name, $msg); + $msg = "this is the version that will be used"; gp_message ("warning", $subr_name, $msg); $msg = "the $GP_DISPLAY_TEXT tool is in the search path"; gp_message ("debug", $subr_name, $msg); $msg = "g_path_to_tools = $g_path_to_tools"; gp_message ("debug", $subr_name, $msg); - } + } else { $msg = "failure to find $GP_DISPLAY_TEXT in the search path"; - gp_message ("debug", $subr_name, $msg); + gp_message ("error", $subr_name, $msg); - $msg = "fatal error executing command $target_cmd"; - gp_message ("abort", $subr_name, $msg); + $g_total_error_count++; + + gp_message ("abort", $subr_name, $g_abort_msg); } } @@ -1690,7 +2001,7 @@ sub 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 +# 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 @@ -1702,17 +2013,23 @@ sub check_loadobjects_are_elf my ($selected_archive) = @_; + my $event_kind_map_regex; + $event_kind_map_regex = '^<event kind="map"\s.*vaddr='; + $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset='; + $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes='; + $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$'; + my $hostname_current = $local_system_config{"hostname_current"}; my $arch = $local_system_config{"processor"}; my $arch_uname_s = $local_system_config{"kernel_name"}; - my $extracted_information; + my $extracted_information; my $elf_magic_number; my $executable_name; my $va_executable_in_hex; - + my $arch_exp; my $hostname_exp; my $os_exp; @@ -1722,19 +2039,21 @@ sub check_loadobjects_are_elf my $rc_b; my $file; my $line; + my $msg; my $name; my $name_path; my $foffset; my $vaddr; my $modes; - my $path_to_map_file; + my $path_to_map_file; my $path_to_log_file; #------------------------------------------------------------------------------ # TBD: Parameterize and should be the first experiment directory from the list. #------------------------------------------------------------------------------ - $path_to_log_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; + $path_to_log_file = + $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; $path_to_log_file .= $selected_archive; $path_to_log_file .= "/log.xml"; @@ -1748,34 +2067,40 @@ sub check_loadobjects_are_elf # This check can probably be removed since the presence of the log.xml file is # checked for in an earlier phase. #------------------------------------------------------------------------------ + $msg = " - unable to open file $path_to_log_file for reading:"; open (LOG_XML, "<", $path_to_log_file) - or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'"); - gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading"); - + or die ($subr_name . $msg . " " . $!); + + $msg = "opened file $path_to_log_file for reading"; + gp_message ("debug", $subr_name, $msg); + while (<LOG_XML>) { $line = $_; chomp ($line); - gp_message ("debug", $subr_name, "read line: $line"); + gp_message ("debugM", $subr_name, "read line: $line"); #------------------------------------------------------------------------------ # Search for the first line starting with "<system". Bail out if found and # parsed. These are two examples: -# <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> -# <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968"> +# <system hostname="ruud-vm" arch="x86_64" \ +# os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> #------------------------------------------------------------------------------ if ($line =~ /^\s*<system\s+/) { - gp_message ("debug", $subr_name, "selected the following line from the log.xml file:"); - gp_message ("debug", $subr_name, "$line"); + $msg = "selected the following line from the log.xml file:"; + gp_message ("debugM", $subr_name, $msg); + gp_message ("debugM", $subr_name, "$line"); if ($line =~ /.*\s+hostname="([^"]+)/) { $hostname_exp = $1; - gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp"); + $msg = "extracted hostname_exp = " . $hostname_exp; + gp_message ("debugM", $subr_name, $msg); } if ($line =~ /.*\s+arch="([^"]+)/) { $arch_exp = $1; - gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp"); + $msg = "extracted arch_exp = " . $arch_exp; + gp_message ("debugM", $subr_name, $msg); } if ($line =~ /.*\s+os="([^"]+)/) { @@ -1787,7 +2112,8 @@ sub check_loadobjects_are_elf { $os_exp = $1; } - gp_message ("debug", $subr_name, "extracted os_exp = $os_exp"); + $msg = "extracted os_exp = " . $os_exp; + gp_message ("debugM", $subr_name, $msg); } last; } @@ -1810,76 +2136,105 @@ sub check_loadobjects_are_elf #TBD: THIS DOES NOT CHECK IF ELF IS FOUND! if (($hostname_current eq $hostname_exp) and - ($arch eq $arch_exp) and + ($arch eq $arch_exp) and ($arch_uname_s eq $os_exp)) { - gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system"); - gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE"); + $msg = "early return: the hostname, architecture and OS match"; + $msg .= " the current system"; + gp_message ("debug", $subr_name, $msg); + $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE"; + gp_message ("debug", $subr_name, $msg); # FAKE return ($TRUE); } if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) { - gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); - for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) + $msg = "selected_archive = " . $selected_archive; + gp_message ("debug", $subr_name, $msg); + for my $i (sort keys + %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) { - gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}"); + $msg = "stored loadobject " . $i . " "; + $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i}; + gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Check if the selected experiment directory has archived files in ELF format. -# If not, use the information in map.xml to get the name of the executable +# If not, use the information in map.xml to get the name of the executable # and the virtual address. #------------------------------------------------------------------------------ if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) { - gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format"); - gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML"); + $msg = "the files in directory $selected_archive/archives are in"; + $msg .= " ELF format"; + gp_message ("debugM", $subr_name, $msg); + $msg = "IGNORE THIS AND USE MAP.XML"; + gp_message ("debugM", $subr_name, $msg); ## return ($TRUE); } - gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format"); + $msg = "the files in directory $selected_archive/archives are not in"; + $msg .= " ELF format"; + gp_message ("debug", $subr_name, $msg); - $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; - $path_to_map_file .= $selected_archive; - $path_to_map_file .= "/map.xml"; + $path_to_map_file = + $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; + $path_to_map_file .= $selected_archive; + $path_to_map_file .= "/map.xml"; - open (MAP_XML, "<", $path_to_map_file) - or die ($subr_name, "unable to open file $path_to_map_file for reading: $!"); - gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading"); + $msg = " - unable to open file $path_to_map_file for reading:"; + open (MAP_XML, "<", $path_to_map_file) + or die ($subr_name . $msg . " " . $!); + $msg = "opened file $path_to_map_file for reading"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Scan the map.xml file. We need to find the name of the executable with the # mode set to 0x005. For this entry we have to capture the virtual address. #------------------------------------------------------------------------------ - $extracted_information = $FALSE; - while (<MAP_XML>) + $extracted_information = $FALSE; + while (<MAP_XML>) { $line = $_; chomp ($line); - gp_message ("debug", $subr_name, "MAP_XML read line = $line"); -## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) - if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) + gp_message ("debugM", $subr_name, "MAP_XML read line = $line"); +#------------------------------------------------------------------------------ +# Replaces this way too long line: +# if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+. +# *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.* +# name="(.*)".*>$/) +#------------------------------------------------------------------------------ + if ($line =~ /$event_kind_map_regex/) { - gp_message ("debug", $subr_name, "target line = $line"); + gp_message ("debugM", $subr_name, "target line = $line"); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); - gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); - gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); + $msg = "extracted vaddr = $vaddr foffset = $foffset"; + $msg .= " modes = $modes"; + gp_message ("debugM", $subr_name, $msg); + $msg = "extracted name_path = $name_path name = $name"; + gp_message ("debugM", $subr_name, $msg); # $error_extracting_information = $TRUE; $executable_name = $name; my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); my $hex_VA = sprintf ("0x%016x", $result_VA); $va_executable_in_hex = $hex_VA; - gp_message ("debug", $subr_name, "set executable_name = $executable_name"); - gp_message ("debug", $subr_name, "set va_executable_in_hex = $va_executable_in_hex"); - gp_message ("debug", $subr_name, "result_VA = $result_VA"); - gp_message ("debug", $subr_name, "hex_VA = $hex_VA"); + + $msg = "set executable_name = " . $executable_name; + gp_message ("debugM", $subr_name, $msg); + $msg = "set va_executable_in_hex = " . $va_executable_in_hex; + gp_message ("debugM", $subr_name, $msg); + $msg = "result_VA = " . $result_VA; + gp_message ("debugM", $subr_name, $msg); + $msg = "hex_VA = " . $hex_VA; + gp_message ("debugM", $subr_name, $msg); + if ($modes eq "005") { $extracted_information = $TRUE; @@ -1887,9 +2242,13 @@ sub check_loadobjects_are_elf } } } + + close (MAP_XML); + if (not $extracted_information) { - my $msg = "cannot find the necessary information in the $path_to_map_file file"; + $msg = "cannot find the necessary information in"; + $msg .= " the $path_to_map_file file"; gp_message ("assertion", $subr_name, $msg); } @@ -1917,26 +2276,42 @@ sub check_metric_values my $current_value; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; my $max_value; + my $msg; my $relative_distance; - @current_metrics = split (" ", $metric_values); + @current_metrics = split (" ", $metric_values); $colour_coded_line = $FALSE; + for my $metric (0 .. $#current_metrics) { $current_value = $current_metrics[$metric]; if (exists ($max_metric_values[$metric])) { $max_value = $max_metric_values[$metric]; - gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); - if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) + + $msg = "metric = $metric current_value = $current_value"; + $msg .= " max_value = $max_value"; + gp_message ("debugXL", $subr_name, $msg); + + if ( ($max_value > 0) and ($current_value > 0) and + ($current_value != $max_value) ) { # TBD: abs needed? - gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); - $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); - gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); + $msg = "metric = $metric current_value = $current_value"; + $msg .= " max_value = $max_value"; + gp_message ("debugXL", $subr_name, $msg); + + $relative_distance = 1.00 - abs ( + ($max_value - $current_value)/$max_value ); + + $msg = "relative_distance = $relative_distance"; + gp_message ("debugXL", $subr_name, $msg); + if ($relative_distance >= $hp_value/100.0) { - gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); + $msg = "metric $metric is within the relative_distance"; + gp_message ("debugXL", $subr_name, $msg); + $colour_coded_line = $TRUE; last; } @@ -1974,80 +2349,218 @@ sub check_support_for_processor } #-- End of subroutine check_support_for_processor #------------------------------------------------------------------------------ -# Check if the value for the user option given is valid. +# Check the command line options for the occurrence of experiments and make +# sure that this list is contigious. No other names are allowed in this list. # -# In case the value is valid, the g_user_settings table is updated. -# Otherwise an error message is printed. +# Terminate execution in case of an error. Otherwise remove the experiment +# names for ARGV (to make the subsequent parsing easier), and return an array +# with the experiment names. # -# The return value is TRUE/FALSE. +# The following patterns are supposed to be detected: +# +# <expdir_1> some other word(s) <expdir_2> +# <expdir> some other word(s) #------------------------------------------------------------------------------ -sub check_user_option +sub check_the_experiment_list { my $subr_name = get_my_name (); - my ($internal_option_name, $value) = @_; +#------------------------------------------------------------------------------ +# The name of an experiment directory can contain any non-whitespace +# character(s), but has to end with .er, or optionally .er/. Multiple +# forward slashes are allowed. +#------------------------------------------------------------------------------ + my $exp_dir_regex = '^(\S+)(\.er)\/*$'; + my $forward_slash_regex = '\/*$'; - my $message; - my $return_value; + my $current_value; + my @exp_dir_list = (); + my $found_experiment = $FALSE; + my $found_non_exp = $FALSE; + my $msg; + my $name_non_exp_dir = ""; + my $no_of_experiments = 0; + my $no_of_invalid_dirs = 0; + my $opt_remainder; + my $valid = $TRUE; + + for my $i (keys @ARGV) + { + $current_value = $ARGV[$i]; + if ($current_value =~ /$exp_dir_regex/) +#------------------------------------------------------------------------------ +# The current value is an experiment. Remove any trailing forward slashes, +# Increment the count, push the value into the array and set the +# found_experiment flag to TRUE. +#------------------------------------------------------------------------------ + { + $no_of_experiments += 1; - 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"}; + $current_value =~ s/$forward_slash_regex//; + push (@exp_dir_list, $current_value); - if (($no_of_arguments >= 1) and - ((not defined ($value)) or (length ($value) == 0))) + if (not $found_experiment) +#------------------------------------------------------------------------------ +# Start checking for the next field(s). +#------------------------------------------------------------------------------ + { + $found_experiment = $TRUE; + } +#------------------------------------------------------------------------------ +# We had found non-experiment names and now see another experiment. Time to +# bail out of the loop. +#------------------------------------------------------------------------------ + if ($found_non_exp) + { + last; + } + } + else + { + if ($found_experiment) +#------------------------------------------------------------------------------ +# The current value is not an experiment, but the value of found_experiment +# indicates at least one experiment has been seen already. This means that +# the list of experiment names is not contiguous and that is a fatal error. +#------------------------------------------------------------------------------ + { + $name_non_exp_dir .= $current_value . " "; + $found_non_exp = $TRUE; + } + } + + } + +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ +# Error handling. +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ + + if ($found_non_exp) +#------------------------------------------------------------------------------ +# The experiment list is not contiguous. +#------------------------------------------------------------------------------ { + $valid = $FALSE; + $msg = "the list with the experiments is not contiguous:"; + gp_message ("error", $subr_name, $msg); + + $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" . + " appears in a list where experiments are expected"; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + } + + if ($no_of_experiments == 0) #------------------------------------------------------------------------------ -# If there was no value given, but it is required, flag an error. -# There could also be a value, but it might be the empty string. -# -# Note that that there are currently no options with multiple values. Should -# these be introduced, the current check may need to be refined. +# The experiment list is empty. #------------------------------------------------------------------------------ + { + $valid = $FALSE; + $msg = "the experiment list is missing from the options"; + gp_message ("error", $subr_name, $msg); - $message = "the $option option requires a value"; - push (@g_user_input_errors, $message); - $return_value = $FALSE; + $g_total_error_count++; } - elsif ($no_of_arguments >= 1) + + if (not $valid) +#------------------------------------------------------------------------------ +# If an error has occurred, print the error(s) and terminate execution. +#------------------------------------------------------------------------------ { + gp_message ("abort", $subr_name, $g_abort_msg); + } + #------------------------------------------------------------------------------ -# 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. +# We now have a list with experiments, but we still need to verify whether they +# exist, and if so, are these valid experiments? #------------------------------------------------------------------------------ - my $valid = verify_if_input_is_valid ($value, $data_type); + for my $exp_dir (@exp_dir_list) + { + $msg = "checking experiment directory $exp_dir"; + gp_message ("debug", $subr_name, $msg); - if ($valid) + if (-d $exp_dir) { - if (($data_type eq "onoff") or ($data_type eq "size")) + $msg = "directory $exp_dir found"; + gp_message ("debug", $subr_name, $msg); +#------------------------------------------------------------------------------ +# Files log.xml and map.xml have to be there. +#------------------------------------------------------------------------------ + if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) { - $g_user_settings{$internal_option_name}{"current_value"} = lc ($value); + $msg = "directory $exp_dir appears to be a valid experiment"; + $msg .= " directory"; + gp_message ("debug", $subr_name, $msg); } else { - $g_user_settings{$internal_option_name}{"current_value"} = $value; + $no_of_invalid_dirs++; + $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir; + $msg .= "/map.xml missing"; + gp_message ("debug", $subr_name, $msg); + + $msg = "directory " . get_basename($exp_dir) . " does not"; + $msg .= " appear to be a valid experiment directory"; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; } - $g_user_settings{$internal_option_name}{"defined"} = $TRUE; - $return_value = $TRUE; } else { - $message = "incorrect value for $option option: $value"; - push (@g_user_input_errors, $message); + $no_of_invalid_dirs++; + $msg = "directory " . get_basename($exp_dir) . " does not exist"; + gp_message ("error", $subr_name, $msg); - $return_value = $FALSE; + $g_total_error_count++; } } - return ($return_value); + if ($no_of_invalid_dirs > 0) +#------------------------------------------------------------------------------ +# This is a fatal error, but for now, we can continue to check for more errors. +# Even if none more are found, execution is terminated before the data is +# generated and processed. In this way we can catch as many errors as +# possible. +#------------------------------------------------------------------------------ + { + my $plural_or_single = ($no_of_invalid_dirs == 1) ? + "one experiment is" : $no_of_invalid_dirs . " experiments are"; + + $msg = $plural_or_single . " not valid"; +## gp_message ("abort", $subr_name, $msg); -} #-- End of subroutine check_user_option +## $g_total_error_count++; + } + +#------------------------------------------------------------------------------ +# Remove the experiments from ARGV and return the array with the experiment +# names. Note that these may, or may not be valid, but if invalid, execution +# terminates before they are used. +#------------------------------------------------------------------------------ + for my $i (1 .. $no_of_experiments) + { + my $poppy = pop (@ARGV); + + $msg = "popped $poppy from ARGV"; + gp_message ("debug", $subr_name, $msg); -#------------------------------------------------------------------------------- -# This subroutine performs multiple checks on the experiment directories. One -# or more failures are fatal. -#------------------------------------------------------------------------------- + $msg = "ARGV after update = " . join (" ", @ARGV); + gp_message ("debug", $subr_name, $msg); + } + + return (\@exp_dir_list); + +} #-- End of subroutine check_the_experiment_list + +#------------------------------------------------------------------------------ +# Perform multiple checks on the experiment directories. +# +# TBD: It needs to be investigated whether all of this is really neccesary. +#------------------------------------------------------------------------------ sub check_validity_exp_dirs { my $subr_name = get_my_name (); @@ -2055,117 +2568,85 @@ sub check_validity_exp_dirs my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; - + my %elf_rats = (); my $dir_not_found = $FALSE; - my $invalid_dir = $FALSE; - my $dir_check_errors = $FALSE; my $missing_dirs = 0; my $invalid_dirs = 0; - + my $archive_dir_not_empty; - my $elf_magic_number; + my $archives_dir; my $archives_file; - my $archives_dir; - my $first_line; my $count_exp_dir_not_elf; - + my $elf_magic_number; + my $first_line; + my $msg; + my $first_time; my $filename; my $comment; - my $selected_archive_has_elf_format; + my $selected_archive_has_elf_format; my $selected_archive; my $archive_dir_selected; my $no_of_files_in_selected_archive; -#------------------------------------------------------------------------------- -# Check if the experiment directories exist and are valid. -#------------------------------------------------------------------------------- - for my $exp_dir (@exp_dir_list) - { - if (not -d $exp_dir) - { - $dir_not_found = $TRUE; - $missing_dirs++; - gp_message ("error", $subr_name, "directory $exp_dir not found"); - $dir_check_errors = $TRUE; - } - else - { -#------------------------------------------------------------------------------- -# Files log.xml and map.xml have to be there. -#------------------------------------------------------------------------------- - gp_message ("debug", $subr_name, "directory $exp_dir found"); - if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) - { - gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory"); - } - else - { - $invalid_dir = $TRUE; - $invalid_dirs++; - gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing"); - gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory"); - $dir_check_errors = $TRUE; - } - } - } - if ($dir_not_found) - { - gp_message ("error", $subr_name, "a total of $missing_dirs directories not found"); - } - if ($invalid_dir) - { - gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid"); - } - -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Initialize ELF status to FALSE. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ ## for my $exp_dir (@exp_dir_list) for my $exp_dir (keys %g_exp_dir_meta_data) { - $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; - $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; + $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Check if the load objects are in ELF format. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ for my $exp_dir (keys %g_exp_dir_meta_data) { - $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; + $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; + $archives_dir .= $exp_dir . "/archives"; $archive_dir_not_empty = $FALSE; $first_time = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; - gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); - gp_message ("debug", $subr_name, "checking $archives_dir"); + $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; + $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}; + gp_message ("debug", $subr_name, $msg); + + $msg = "checking $archives_dir"; + gp_message ("debug", $subr_name, $msg); while (glob ("$archives_dir/*")) { $filename = get_basename ($_); - gp_message ("debug", $subr_name, "processing file: $filename"); + + $msg = "processing file: $filename"; + gp_message ("debug", $subr_name, $msg); $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; $archive_dir_not_empty = $TRUE; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Replaces the ELF_RATS part in elf_phdr. # # Challenge: splittable_mrg.c_I0txnOW_Wn5 # # TBD: Store this for each relevant experiment directory. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my $last_dot = rindex ($filename,"."); my $underscore_before_dot = $TRUE; my $first_underscore = -1; - gp_message ("debugXL", $subr_name, "last_dot = $last_dot"); + + $msg = "last_dot = $last_dot"; + gp_message ("debugXL", $subr_name, $msg); + while ($underscore_before_dot) { $first_underscore = index ($filename, "_", $first_underscore+1); @@ -2175,27 +2656,33 @@ sub check_validity_exp_dirs } } my $original_name = substr ($filename, 0, $first_underscore); - gp_message ("debug", $subr_name, "stripped archive name: $original_name"); + $msg = "stripped archive name: " . $original_name; + gp_message ("debug", $subr_name, $msg); if (not exists ($elf_rats{$original_name})) { $elf_rats{$original_name} = [$filename, $exp_dir]; } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # We only need to detect the presence of an object once. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if ($first_time) { $first_time = $FALSE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; - gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); + $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; + $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; + + gp_message ("debugXL", $subr_name, $msg); } } } #-- End of loop over experiment directories for my $exp_dir (sort keys %g_exp_dir_meta_data) { - my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; - gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty")); + my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; + $msg = "archive directory " . $exp_dir . "/archives is"; + $msg .= " " . ($empty ? "empty" : "not empty"); + gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -2203,21 +2690,26 @@ sub check_validity_exp_dirs #------------------------------------------------------------------------------ for my $exp_dir (sort keys %g_exp_dir_meta_data) { - $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { - $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; - gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir"); + $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; + $archives_dir .= $exp_dir . "/archives"; + $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Check if any of the loadobjects is of type ELF. Bail out on the first one # found. The assumption is that all other loadobjects must be of type ELF too # then. #------------------------------------------------------------------------------ - for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) + for my $aname (sort keys + %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { - $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives/" . $aname; + $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; + $filename .= $exp_dir . "/archives/" . $aname; + $msg = " - unable to open file $filename for reading:"; open (ARCF,"<", $filename) - or die ("unable to open file $filename for reading - '$!'"); + or die ($subr_name . $msg . " " . $!); $first_line = <ARCF>; close (ARCF); @@ -2230,10 +2722,10 @@ sub check_validity_exp_dirs # if ($first_line =~ /^\177ELF.*/) $elf_magic_number = unpack ('H8', $first_line); -# gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number"); if ($elf_magic_number eq "7f454c46") { - $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE; + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = + $TRUE; $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE; last; } @@ -2243,22 +2735,24 @@ sub check_validity_exp_dirs for my $exp_dir (sort keys %g_exp_dir_meta_data) { - $comment = "the loadobjects in the archive in $exp_dir are "; - $comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in "; - $comment .= "ELF format"; - gp_message ("debug", $subr_name, $comment); + $msg = "the loadobjects in the archive in $exp_dir are"; + $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? + " in" : " not in"; + $msg .= " ELF format"; + gp_message ("debug", $subr_name, $msg); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { - gp_message ("debug", $subr_name, "there are no archived files in $exp_dir"); + $msg = "there are no archived files in " . $exp_dir; + gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ -# If there are archived files and they are not in ELF format, a debug is -# issued. +# If there are archived files and they are not in ELF format, a debug message +# is issued. # # TBD: Bail out? #------------------------------------------------------------------------------ @@ -2267,12 +2761,14 @@ sub check_validity_exp_dirs { if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) { - $count_exp_dir_not_elf++; + $count_exp_dir_not_elf++; } } if ($count_exp_dir_not_elf != 0) { - gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects"); + $msg = "there are $count_exp_dir_not_elf experiments with non-ELF"; + $msg .= " load objects"; + gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -2290,19 +2786,24 @@ sub check_validity_exp_dirs ## for my $exp_dir (sort @exp_dir_list) for my $exp_dir (sort keys %g_exp_dir_meta_data) { - gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir"); - gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); + $msg = "exp_dir = " . $exp_dir; + gp_message ("debugXL", $subr_name, $msg); + $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"; + $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; + gp_message ("debugXL", $subr_name, $msg); if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $selected_archive = $exp_dir; $archive_dir_not_empty = $TRUE; $archive_dir_selected = $TRUE; - $selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE; + $selected_archive_has_elf_format = + ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? + $TRUE : $FALSE; last; } } - if (not $archive_dir_selected) + if (not $archive_dir_selected) #------------------------------------------------------------------------------ # None are found and pick the first one without archived files. #------------------------------------------------------------------------------ @@ -2319,35 +2820,52 @@ sub check_validity_exp_dirs } } } - gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis"); - gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty")); - gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format"); + + $msg = "experiment $selected_archive has been selected for"; + $msg .= " archive analysis"; + gp_message ("debug", $subr_name, $msg); + $msg = "this archive is"; + $msg .= $archive_dir_not_empty ? " not empty" : " empty"; + gp_message ("debug", $subr_name, $msg); + $msg = "this archive is"; + $msg .= $selected_archive_has_elf_format ? " in" : " not in"; + $msg .= " ELF format"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Get the size of the hash that contains the archived files. #------------------------------------------------------------------------------ ## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); - $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; - gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive"); + $no_of_files_in_selected_archive = + $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; + $msg = "number of files in archive $selected_archive is"; + $msg .= " " . $no_of_files_in_selected_archive; + gp_message ("debug", $subr_name, $msg); for my $exp_dir (sort keys %g_exp_dir_meta_data) { my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; - gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty")); + $msg = "archive directory $exp_dir/archives is"; + $msg .= $is_empty ? " empty" : " not empty"; + gp_message ("debug", $subr_name, $msg); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { - for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) + for my $object (sort keys + %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { - gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}"); + $msg = $exp_dir . " " . $object . " "; + $msg .= + $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}; + gp_message ("debug", $subr_name, $msg); } } } - return ($dir_check_errors, $archive_dir_not_empty, $selected_archive, \%elf_rats); + return ($archive_dir_not_empty, $selected_archive, \%elf_rats); } #-- End of subroutine check_validity_exp_dirs @@ -2378,7 +2896,7 @@ sub color_string { $colored_string .= "</b>"; } - $colored_string .= "</font>"; + $colored_string .= "</font>"; return ($colored_string); @@ -2397,25 +2915,29 @@ sub create_exp_info my @experiment_data = @{ $experiment_data_ref }; my @experiment_stats_html = (); - my $experiment_stats_line; + my $experiment_stats_line; + my $msg; my $plural; $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; $experiment_stats_line = "<h3>\n"; - $experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n"; + $experiment_stats_line .= "Full pathnames to the input experiment"; + $experiment_stats_line .= $plural . "\n"; $experiment_stats_line .= "</h3>\n"; $experiment_stats_line .= "<pre>\n"; for my $i (0 .. $#experiment_dir_list) { - $experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n"; + $experiment_stats_line .= $experiment_dir_list[$i] . " (" ; + $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n"; } $experiment_stats_line .= "</pre>\n"; push (@experiment_stats_html, $experiment_stats_line); - gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --"); + $msg = "experiment_stats_line = " . $experiment_stats_line; + gp_message ("debugXL", $subr_name, $msg); return (\@experiment_stats_html); @@ -2448,9 +2970,11 @@ sub create_html_credits my $msg; my $the_date; - my @months = qw (January February March April May June July August September October November December); + my @months = qw (January February March April May June July + August September October November December); - my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime (); + my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = + localtime (); $year += 1900; @@ -2484,17 +3008,18 @@ sub create_html_header my $title = ${ $title_ref }; my $LANG = $g_locale_settings{"LANG"}; - my $background_color = $g_html_color_scheme{"background_color_page"}; + my $background_color = $g_html_color_scheme{"background_color_page"}; - my $html_header; + my $html_header; $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n"; $html_header .= "<html lang=\"$LANG\">\n"; $html_header .= "<head>\n"; - $html_header .= "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n"; + $html_header .= "<meta http-equiv=\"content-type\""; + $html_header .= " content=\"text/html; charset=iso-8859-1\">\n"; $html_header .= "<title>" . $title . "</title>\n"; $html_header .= "</head>\n"; - $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; + $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; $html_header .= "<style>\n"; $html_header .= "div.left {\n"; $html_header .= "text-align: left;\n"; @@ -2515,113 +3040,14 @@ sub create_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 }; @@ -2636,8 +3062,10 @@ sub create_table for my $i (sort keys @table_definition) { - $html_table_line = ${ create_table_entry_exp (\$table_definition[$i]{"name"}, - \$table_definition[$i]{"key"}, \@experiment_data) }; + $html_table_line = ${ + create_table_entry_exp (\$table_definition[$i]{"name"}, + \$table_definition[$i]{"key"}, + \@experiment_data) }; push (@html_exp_table_data, $html_table_line); my $msg = "i = $i html_table_line = $html_table_line"; @@ -2651,9 +3079,9 @@ sub create_table } #-- 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 (); @@ -2664,11 +3092,13 @@ sub create_table_entry_exp my $key = ${ $key_ref }; my @experiment_data = @{ $experiment_data_ref }; - gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key"); - my $html_line; + my $msg; - $html_line = "<tr><div class=\"left\"><td><b> "; + $msg = "entry_name = $entry_name key = $key"; + gp_message ("debugXL", $subr_name, $msg); + +## $html_line = "<tr><div class=\"left\"><td><b> "; $html_line = "<tr><div class=\"right\"><td><b> "; $html_line .= $entry_name; $html_line .= " </b></td>"; @@ -2676,12 +3106,15 @@ sub create_table_entry_exp { if (exists ($experiment_data[$i]{$key})) { - $html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>"; + $html_line .= "<td> " . $experiment_data[$i]{$key}; + $html_line .= " </td>"; } else { -## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist"); - gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist"); + $msg = "experiment_data[$i]{$key} does not exist"; +## gp_message ("assertion", $subr_name, $msg); +# TBD: warning or error? + gp_message ("warning", $subr_name, $msg); } } $html_line .= "</div></tr>\n"; @@ -2692,9 +3125,9 @@ sub create_table_entry_exp } #-- 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 (); @@ -2703,6 +3136,7 @@ sub create_table_header_exp my @experiment_data = @{ $experiment_data_ref }; my $html_header_line; + my $msg; $html_header_line = "<style>\n"; $html_header_line .= "table, th, td {\n"; @@ -2716,54 +3150,62 @@ sub create_table_header_exp for my $i (sort keys @experiment_data) { - $html_header_line .= "<th> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>"; + $html_header_line .= "<th> Experiment ID "; + $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>"; } $html_header_line .= "</div></tr>\n"; - gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line"); + $msg = "html_header_line = " . $html_header_line; + gp_message ("debugXL", $subr_name, $msg); return (\$html_header_line); } #-- End of subroutine create_table_header_exp -#------------------------------------------------------------------------------- -# Handle where the output should go. If needed, a directory is created where +#------------------------------------------------------------------------------ +# Handle where the output should go. If needed, a directory is created where # the results will go. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub define_the_output_directory { my $subr_name = get_my_name (); my ($define_new_output_dir, $overwrite_output_dir) = @_; + my $msg; my $outputdir; -#------------------------------------------------------------------------------- -# If neither -o or -O are set, find the next number to be used in the name for +#------------------------------------------------------------------------------ +# If neither -o or -O are set, find the next number to be used in the name for # the default output directory. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if ((not $define_new_output_dir) and (not $overwrite_output_dir)) { my $dir_id = 1; - while (-d "er.".$dir_id.".html") + while (-d "er.".$dir_id.".html") { $dir_id++; } $outputdir = "er.".$dir_id.".html"; } if (-d $outputdir) { -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The -o option is used, but the directory already exists. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if ($define_new_output_dir) { - gp_message ("error", $subr_name, "directory $outputdir already exists"); - gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory"); + $msg = "directory $outputdir already exists"; + gp_message ("error", $subr_name, $msg); + $g_total_error_count++; + + $msg = "use the -O/--overwrite option to overwrite an existing"; + $msg .= " directory"; + gp_message ("abort", $subr_name, $msg); } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # This is a bit risky, so we proceed with caution. The output directory exists, # but it is okay to overwrite it. It is removed here and created again below. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ elsif ($overwrite_output_dir) { my $target_cmd = $g_mapped_cmds{"rm"}; @@ -2772,25 +3214,29 @@ sub define_the_output_directory if ($error_code != 0) { gp_message ("error", $subr_name, $rm_output); - gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); + $msg = "fatal error when trying to remove " . $outputdir; + gp_message ("abort", $subr_name, $msg); } else { - gp_message ("debug", $subr_name, "directory $outputdir has been removed"); + $msg = "directory $outputdir has been removed"; + gp_message ("debug", $subr_name, $msg); } } } -#------------------------------------------------------------------------------- -# When we get here, the fatal scenarios have been cleared and the name for +#------------------------------------------------------------------------------ +# When we get here, the fatal scenarios have been cleared and the name for # $outputdir is known. Time to create it. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if (mkdir ($outputdir, 0777)) { - gp_message ("debug", $subr_name, "created output directory $outputdir"); + $msg = "created output directory " . $outputdir; + gp_message ("debug", $subr_name, $msg); } - else + else { - gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir"); + $msg = "a fatal problem occurred when creating directory " . $outputdir; + gp_message ("abort", $subr_name, $msg); } return ($outputdir); @@ -2810,12 +3256,16 @@ sub determine_base_va_address my ($executable_name, $base_va_executable, $loadobj, $routine) = @_; + my $msg; my $name_loadobject; my $base_va_address; - gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable"); - gp_message ("debugXL", $subr_name, "loadobj = $loadobj"); - gp_message ("debugXL", $subr_name, "routine = $routine"); + $msg = "base_va_executable = " . $base_va_executable; + gp_message ("debugXL", $subr_name, $msg); + $msg = "loadobj = " . $loadobj; + gp_message ("debugXL", $subr_name, $msg); + $msg = "routine = " . $routine; + gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Strip the pathname from the load object name. @@ -2823,7 +3273,7 @@ sub determine_base_va_address $name_loadobject = get_basename ($loadobj); #------------------------------------------------------------------------------ -# If the load object is the executable, return the base address determined +# If the load object is the executable, return the base address determined # earlier. Otherwise return 0x0. Note that I am not sure if this is always # the right thing to do, but for .so files it seems to work out fine. #------------------------------------------------------------------------------ @@ -2835,18 +3285,21 @@ sub determine_base_va_address { $base_va_address = "0x0"; } - + my $decimal_address = bigint::hex ($base_va_address); - gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)"); + + $msg = "return base_va_address = $base_va_address"; + $msg .= " (decimal: $decimal_address)"; + gp_message ("debugXL", $subr_name, $msg); return ($base_va_address); } #-- End of subroutine determine_base_va_address -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub determine_base_virtual_address { my $subr_name = get_my_name (); @@ -2855,28 +3308,33 @@ sub determine_base_virtual_address my @exp_dir_list = @{ $exp_dir_list_ref }; - my $full_path_exec; my $executable_name; + my $full_path_exec; + my $msg; + my $path_to_map_file; my $va_executable_in_hex; - my $path_to_map_file; - for my $exp_dir (keys %g_exp_dir_meta_data) { - $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; + $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; $path_to_map_file .= $exp_dir; $path_to_map_file .= "/map.xml"; - ($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file); + ($full_path_exec, $executable_name, $va_executable_in_hex) = + extract_info_from_map_xml ($path_to_map_file); $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec; $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name; $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex; - gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); - gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec"); - gp_message ("debug", $subr_name, "executable_name = $executable_name"); - gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); + $msg = "exp_dir = " . $exp_dir; + gp_message ("debug", $subr_name, $msg); + $msg = "full_path_exece = " . $full_path_exec; + gp_message ("debug", $subr_name, $msg); + $msg = "executable_name = " . $executable_name; + gp_message ("debug", $subr_name, $msg); + $msg = "va_executable_in_hex = " . $va_executable_in_hex; + gp_message ("debug", $subr_name, $msg); } return (0); @@ -2890,114 +3348,143 @@ sub determine_decimal_separator { my $subr_name = get_my_name (); - my $ignore_count; - my $decimal_separator; + my $cmd_output; my $convert_to_dot; - my $field; - my $target_found; + my $decimal_separator; my $error_code; - my $cmd_output; + my $field; + my $ignore_count; + my @locale_info = (); + my $msg; my $target_cmd; - my @locale_info; + my $target_found; my $default_decimal_separator = "\\."; $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC"; ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); - + if ($error_code != 0) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # This is unlikely to happen, but you never know. To reduce the nesting level, # return right here in case of an error. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - gp_message ("error", $subr_name, "failure to execute the command $target_cmd"); - + $msg = "failure to execute the command " . $target_cmd; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + $convert_to_dot = $TRUE; return ($error_code, $default_decimal_separator, $convert_to_dot); } -#------------------------------------------------------------------------------- -# Scan the locale info and search for the target line of the form +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ +# Scan the locale info and search for the target line of the form # decimal_point="<target>" where <target> is either a dot, or a comma. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Split the output into the different lines and scan for the line we need. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ @locale_info = split ("\n", $cmd_output); $target_found = $FALSE; - for my $line (@locale_info) + for my $line (@locale_info) { chomp ($line); - gp_message ("debug", $subr_name, "line from locale_info = $line"); - if ($line =~ /decimal_point=/) + $msg = "line from locale_info = " . $line; + gp_message ("debug", $subr_name, $msg); + + if ($line =~ /decimal_point=/) { -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Found the target line. Split this line to get the value field. -#------------------------------------------------------------------------------- - my @split_line = split ("=", $line); +#------------------------------------------------------------------------------ + my @split_line = split ("=", $line); -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # There should be 2 fields. If not, something went wrong. -#------------------------------------------------------------------------------- - if (scalar @split_line != 2) +#------------------------------------------------------------------------------ + if (scalar @split_line != 2) { # if (scalar @split_line == 2) { # $target_found = $FALSE; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Remove the newline before printing the variables. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ $ignore_count = chomp ($line); $ignore_count = chomp (@split_line); - gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format"); - gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields"); - gp_message ("debug", $subr_name, "warning - the default decimal separator will be used"); + + $msg = "line $line matches the search, but the decimal"; + $msg .= " separator has the wrong format"; + gp_message ("warning", $subr_name, $msg); + $msg = "the splitted line is [@split_line] and does not"; + $msg .= " contain 2 fields"; + gp_message ("warning", $subr_name, $msg); + $msg = "the default decimal separator will be used"; + gp_message ("warning", $subr_name, $msg); + + $g_total_warning_count++; } else { -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # We know there are 2 fields and the second one has the decimal point. -#------------------------------------------------------------------------------- - gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]"); +#------------------------------------------------------------------------------ + $msg = "split_line[1] = " . $split_line[1]; + gp_message ("debug", $subr_name, $msg); chomp ($split_line[1]); $field = $split_line[1]; if (length ($field) != 3) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The field still includes the quotes. Check if the string has length 3, which # should be the case, but if not, we flag an error. The error code is set such # that the callee will know a problem has occurred. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field"); + $msg = "unexpected output from the $target_cmd command:"; + $msg .= " " . $field; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + $error_code = 1; last; } - gp_message ("debug", $subr_name, "field = ->$field<-"); + $msg = "field = ->$field<-"; + gp_message ("debug", $subr_name, $msg); if (($field eq "\".\"") or ($field eq "\",\"")) -#------------------------------------------------------------------------------- -# Found the separator. Capture the character between the quotes. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Found the separator. Capture the character between the quotes. +#------------------------------------------------------------------------------ { $target_found = $TRUE; $decimal_separator = substr ($field,1,1); - gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop"); + $msg = "decimal_separator = $decimal_separator--end"; + $msg .= " skip remainder of loop"; + gp_message ("debug", $subr_name, $msg); last; } } } } - if (not $target_found) + if (not $target_found) { $decimal_separator = $default_decimal_separator; - gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator"); - } + $msg = "cannot determine the decimal separator"; + $msg .= " - use the default " . $decimal_separator; + gp_message ("warning", $subr_name, $msg); + + $g_total_warning_count++; + } if ($decimal_separator ne ".") { @@ -3027,21 +3514,26 @@ sub dump_function_info my %function_info = %{$function_info_ref}; my $kip; + my $msg; + + $msg = "function_info for " . $name; + gp_message ("debug", $subr_name, $msg); - gp_message ("debug", $subr_name, "function_info for $name"); $kip = 0; for my $farray ($function_info{$name}) { for my $elm (@{$farray}) { - gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}"); + $msg = $kip . ": routine = " . ${$elm}{"routine"}; + gp_message ("debug", $subr_name, $msg); for my $key (sort keys %{$elm}) { if ($key eq "routine") { next; } - gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}"); + $msg = $kip . ": $key = " . ${$elm}{$key}; + gp_message ("debug", $subr_name, $msg); } $kip++; } @@ -3052,210 +3544,29 @@ sub dump_function_info } #-- 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, + my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; my %elf_rats = %{$elf_rats_ref}; + my $msg; my $return_value; #------------------------------------------------------------------------------ # TBD. Quick check. Can be moved up the call tree. #------------------------------------------------------------------------------ - if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") ) + if ( $elf_arch ne "Linux" ) { - gp_message ("abort", $subr_name, "$elf_arch is not a supported OS"); + $msg = $elf_arch . " is not a supported OS"; + gp_message ("error", $subr_name, $msg); + $g_total_error_count++; + gp_message ("abort", $subr_name, $g_abort_msg); } #------------------------------------------------------------------------------ @@ -3268,20 +3579,31 @@ sub elf_phdr if ($elf_loadobjects_found) { gp_message ("debugXL", $subr_name, "calling elf_phdr_usual"); - $return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats); + $return_value = elf_phdr_usual ($elf_arch, + $loadobj, + $routine, + \%elf_rats); } - else + else { gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes"); - $return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR); + $return_value = elf_phdr_sometimes ($elf_arch, + $loadobj, + $routine, + $ARCHIVES_MAP_NAME, + $ARCHIVES_MAP_VADDR); } gp_message ("debug", $subr_name, "the return value = $return_value"); if (not $return_value) { - gp_message ("abort", $subr_name, "need to handle a return value of FALSE"); - } + $msg = "need to handle a return value of FALSE"; + gp_message ("error", $subr_name, $msg); + $g_total_error_count++; + gp_message ("abort", $subr_name, $g_abort_msg); + } + return ($return_value); } #-- End of subroutine elf_phdr @@ -3293,7 +3615,7 @@ sub elf_phdr_sometimes { my $subr_name = get_my_name (); - my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, + my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR) = @_; my $arch_uname_s = $local_system_config{"kernel_name"}; @@ -3304,10 +3626,11 @@ sub elf_phdr_sometimes gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); gp_message ("debug", $subr_name, "arch = $arch"); - my $target_cmd; - my $command_string; - my $error_code; my $cmd_output; + my $command_string; + my $error_code; + my $msg; + my $target_cmd; my $line; my $blo; @@ -3332,8 +3655,8 @@ sub elf_phdr_sometimes if ($ARCHIVES_MAP_NAME eq $blo) { return ($ARCHIVES_MAP_VADDR); - } - else + } + else { return ($FALSE); } @@ -3343,9 +3666,11 @@ sub elf_phdr_sometimes #------------------------------------------------------------------------------ # We are masquerading between systems, must leave #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); + $msg = "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"; + gp_message ("debug", $subr_name, $msg); return ($FALSE); } + if ($loadobj eq "DYNAMIC_FUNCTIONS") #------------------------------------------------------------------------------ # Linux vDSO, leave for now @@ -3366,8 +3691,8 @@ sub elf_phdr_sometimes if ($ARCHIVES_MAP_NAME eq $blo) { return ($ARCHIVES_MAP_VADDR); - } - else + } + else { return ($FALSE); } @@ -3387,13 +3712,20 @@ sub elf_phdr_usual my %elf_rats = %{$elf_rats_ref}; + my $load_long_regex; + $load_long_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)'; + $load_long_regex .= '\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; + my $load_short_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$'; + my $re_regex = '^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; + my $return_code; my $cmd_output; my $target_cmd; - my $command_string; + my $command_string; my $error_code; my $error_code1; my $error_code2; + my $msg; my ($elf_offset, $loadobjARC); my ($i, @foo, $foo, $foo1, $p_vaddr, $rc); @@ -3401,10 +3733,13 @@ sub elf_phdr_usual my $arch_uname_s = $local_system_config{"kernel_name"}; - gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"); + $msg = "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"; + gp_message ("debug", $subr_name, $msg); my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj); - gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj)); + + $msg = "base = $base " . basename ($loadobj); + gp_message ("debug", $subr_name, $msg); if ($elf_arch eq "Linux") { @@ -3414,7 +3749,10 @@ sub elf_phdr_usual # We are masquerading between systems, must leave. # Maybe we could use ELF_RATS #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); + $msg = "masquerading arch_uname_s->" . $arch_uname_s; + $msg .= " elf_arch->" . $elf_arch; + gp_message ("debug", $subr_name, $msg); + return ($FALSE); } if ($loadobj eq "DYNAMIC_FUNCTIONS") @@ -3431,8 +3769,10 @@ sub elf_phdr_usual ($error_code1, $cmd_output) = execute_system_cmd ($command_string); - gp_message ("debug", $subr_name, "executed command_string = $command_string"); - gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); + $msg = "executed command_string = " . $command_string; + gp_message ("debug", $subr_name, $msg); + $msg = "cmd_output = " . $cmd_output; + gp_message ("debug", $subr_name, $msg); if ($error_code1 != 0) { @@ -3445,24 +3785,32 @@ sub elf_phdr_usual if (exists ($elf_rats{$loadobjARC})) { - my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]"; + my $elfoid; + $elfoid = $elf_rats{$loadobjARC}[1] . "/archives/"; + $elfoid .= $elf_rats{$loadobjARC}[0]; $target_cmd = $g_mapped_cmds{"readelf"}; $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null"; - ($error_code2, $cmd_output) = execute_system_cmd ($command_string); - + ($error_code2, $cmd_output) = + execute_system_cmd ($command_string); + if ($error_code2 != 0) { - gp_message ("abort", $subr_name, "call failure for $command_string"); + $msg = "call failure for " . $command_string; + gp_message ("error", $subr_name, $msg); + $g_total_error_count++; + gp_message ("abort", $subr_name, $g_abort_msg); } else { - gp_message ("debug", $subr_name, "executed command_string = $command_string"); - gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); + $msg = "executed command_string = " . $command_string; + gp_message ("debug", $subr_name, $msg); + $msg = "cmd_output = " . $cmd_output; + gp_message ("debug", $subr_name, $msg); } } - else + else { - my $msg = "elf_rats{$loadobjARC} does not exist"; + $msg = "elf_rats{$loadobjARC} does not exist"; gp_message ("assertion", $subr_name, $msg); } } @@ -3472,7 +3820,7 @@ sub elf_phdr_usual # 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 @@ -3499,12 +3847,13 @@ sub elf_phdr_usual # 0x0000000000000000 0x0000000000000000 RW 10 # GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 # 0x0000000000000238 0x0000000000000238 R 1 -# +# # Section to Segment mapping: # Segment Sections... # 00 # 01 .interp -# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt +# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym +# .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt # 03 .init .plt .text .fini # 04 .rodata .eh_frame_hdr .eh_frame # 05 .init_array .fini_array .dynamic .got .got.plt .data .bss @@ -3531,11 +3880,11 @@ sub elf_phdr_usual # 0x0000000000001010 0x0000000000001010 R E 200000 #------------------------------------------------------------------------------ @foo = split ("\n",$cmd_output); - for $i (0 .. $#foo) + for $i (0 .. $#foo) { $foo = $foo[$i]; chomp ($foo); - if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) + if ($foo =~ /$load_long_regex/) { $Offset = $1; $VirtAddr = $2; @@ -3546,11 +3895,12 @@ sub elf_phdr_usual $Align = $7; $elf_offset = $VirtAddr; - gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset"); + $msg = "single line version elf_offset = " . $elf_offset; + gp_message ("debug", $subr_name, $msg); return ($elf_offset); } - elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/) - { + elsif ($foo =~ /$load_short_regex/) + { #------------------------------------------------------------------------------ # is it a two line version? #------------------------------------------------------------------------------ @@ -3559,67 +3909,23 @@ sub elf_phdr_usual $PhysAddr = $3; if ($i != $#foo) { - $foo1 = $foo[$i + 1]; + $foo1 = $foo[$i + 1]; chomp ($foo1); - if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) + if ($foo1 =~ /$re_regex/) { $FileSiz = $1; $MemSiz = $2; $Flg = $3; $Align = $4; $elf_offset = $VirtAddr; - gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset"); + $msg = "two line version elf_offset = " . $elf_offset; + gp_message ("debug", $subr_name, $msg); return ($elf_offset); } } } } } - elsif ($elf_arch eq "SunOS") - { -#------------------------------------------------------------------------------ -#Program Header[3]: -# p_vaddr: 0x10000 p_flags: [ PF_X PF_R ] -# folowed by -# p_paddr: 0 p_type: [ PT_LOAD ] -#------------------------------------------------------------------------------ - if ($arch_uname_s ne $elf_arch) -#------------------------------------------------------------------------------ -# we are masquerading between systems, must leave -#------------------------------------------------------------------------------ - { - gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch"); - return (0); - } - $target_cmd = $g_mapped_cmds{"elfdump"}; - $command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null"; - ($error_code, $cmd_output) = execute_system_cmd ($command_string); - if ($error_code != 0) - { - gp_message ("debug", $subr_name,"call failure for $command_string"); - die ("$target_cmd call failure"); - } - my @foo = split ("\n",$cmd_output); - for $i (0 .. $#foo) - { - $foo = $foo[$i]; - chomp ($foo); - if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/) - { - $p_vaddr = $1; # probably - if ($i != $#foo) - { - $foo1 = $foo[$i + 1]; - chomp ($foo1); - if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/) - { - $elf_offset = $p_vaddr; - return ($elf_offset); - } - } - } - } - } } #-- End of subroutine elf_phdr_usual @@ -3633,21 +3939,31 @@ sub execute_system_cmd my ($target_cmd) = @_; + my $cmd_output; + my $error_code; + my $msg; + chomp ($target_cmd); - my $cmd_output = qx ($target_cmd); - my $error_code = ${^CHILD_ERROR_NATIVE}; + $cmd_output = qx ($target_cmd); + $error_code = ${^CHILD_ERROR_NATIVE}; if ($error_code != 0) { - gp_message ("error", $subr_name, "failure executing command $target_cmd"); - gp_message ("error", $subr_name, "error code = $error_code"); + chomp ($cmd_output); + $msg = "failure executing command " . $target_cmd; + gp_message ("error", $subr_name, $msg); + $msg = "error code = " . $error_code; + gp_message ("error", $subr_name, $msg); + $msg = "cmd_output = " . $cmd_output; + + gp_message ("error", $subr_name, $msg); + $g_total_error_count++; } else { - chomp ($cmd_output); - gp_message ("debugM", $subr_name, "executed command $target_cmd"); - gp_message ("debugM", $subr_name, "cmd_output = $cmd_output"); + $msg = "executed command " . $target_cmd; + gp_message ("debugXL", $subr_name, $msg); } return ($error_code, $cmd_output); @@ -3655,7 +3971,7 @@ sub execute_system_cmd } #-- End of subroutine execute_system_cmd #------------------------------------------------------------------------------ -# Scan the input file, which should be a gprofng generated map.xml file, and +# Scan the input file, which should be a gprofng generated map.xml file, and # extract the relevant information. #------------------------------------------------------------------------------ sub extract_info_from_map_xml @@ -3664,25 +3980,37 @@ sub extract_info_from_map_xml my ($input_map_xml_file) = @_; + my $map_xml_regex; + $map_xml_regex = '<event kind="map"\s.*'; + $map_xml_regex .= 'vaddr="0x([0-9a-fA-F]+)"\s+.*'; + $map_xml_regex .= 'foffset="\+*0x([0-9a-fA-F]+)"\s.*'; + $map_xml_regex .= 'modes="0x([0-9]+)"\s.*'; + $map_xml_regex .= 'name="(.*)".*>$'; + my $extracted_information; my $input_line; my $vaddr; my $foffset; + my $msg; my $modes; my $name_path; my $name; my $full_path_exec; my $executable_name; - my $va_executable_in_hex; + my $result_VA; + my $va_executable_in_hex; + $msg = "- unable to open file $input_map_xml_file for reading:"; open (MAP_XML, "<", $input_map_xml_file) - or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!"); - gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading"); + or die ($subr_name . $msg . " " . $!); + + $msg = "opened file $input_map_xml_file for reading"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ -# Scan the file. We need to find the name of the executable with the mode set -# to 0x005. For this entry we have to capture the name, the mode, the virtual +# Scan the file. We need to find the name of the executable with the mode set +# to 0x005. For this entry we have to capture the name, the mode, the virtual # address and the offset. #------------------------------------------------------------------------------ $extracted_information = $FALSE; @@ -3690,36 +4018,46 @@ sub extract_info_from_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="(.*)".*>$/) + + $msg = "read input_line = $input_line"; + gp_message ("debug", $subr_name, $msg); + + if ($input_line =~ /^$map_xml_regex/) { - gp_message ("debug", $subr_name, "target line = $input_line"); + $msg = "target line = $input_line"; + gp_message ("debug", $subr_name, $msg); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); - gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); - gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); + + $msg = "extracted vaddr = $vaddr foffset = $foffset"; + $msg .= " modes = $modes"; + gp_message ("debug", $subr_name, $msg); + + $msg = "extracted name_path = $name_path name = $name"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ -# The base virtual address is calculated as vaddr-foffset. Although Perl +# The base virtual address is calculated as vaddr-foffset. Although Perl # handles arithmetic in hex, we take the safe way here. Maybe overkill, but # I prefer to be safe than sorry in cases like this. #------------------------------------------------------------------------------ - $full_path_exec = $name_path; - $executable_name = $name; - my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); + $full_path_exec = $name_path; + $executable_name = $name; + $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); $va_executable_in_hex = sprintf ("0x%016x", $result_VA); ## $ARCHIVES_MAP_NAME = $name; ## $ARCHIVES_MAP_VADDR = $va_executable_in_hex; -## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); -## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); - gp_message ("debug", $subr_name, "result_VA = $result_VA"); - gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); + $msg = "result_VA = $result_VA"; + gp_message ("debug", $subr_name, $msg); + + $msg = "va_executable_in_hex = $va_executable_in_hex"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Stop reading when we found the correct entry. @@ -3734,20 +4072,24 @@ sub extract_info_from_map_xml if (not $extracted_information) { - my $msg = "cannot find the necessary information in file $input_map_xml_file"; + $msg = "cannot find the necessary information in file"; + $msg .= " " . $input_map_xml_file; gp_message ("assertion", $subr_name, $msg); } - gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec"); - gp_message ("debug", $subr_name, "executable_name = $executable_name"); - gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); + $msg = "full_path_exec = $full_path_exec"; + gp_message ("debug", $subr_name, $msg); + $msg = "executable_name = $executable_name"; + gp_message ("debug", $subr_name, $msg); + $msg = "va_executable_in_hex = $va_executable_in_hex"; + gp_message ("debug", $subr_name, $msg); return ($full_path_exec, $executable_name, $va_executable_in_hex); } #-- End of subroutine extract_info_from_map_xml #------------------------------------------------------------------------------ -# This routine analyzes the metric line and extracts the metric specifics +# This routine analyzes the metric line and extracts the metric specifics # from it. # Example input: Exclusive Total CPU Time: e.%totalcpu #------------------------------------------------------------------------------ @@ -3802,7 +4144,7 @@ sub extract_metric_specifics # $metric_spec =~ s/\%//; # print "DB: after \$metric_spec = $metric_spec\n"; - return ($metric_spec, $metric_flavor, $metric_visibility, + return ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description); } else @@ -3813,6 +4155,255 @@ sub extract_metric_specifics } #-- End of subroutine extract_metric_specifics #------------------------------------------------------------------------------ +# Extract the option value(s) from the input array. In case the number of +# values execeeds the specified limit, warning messages are printed. +# +# In case the option value is valid, g_user_settings is updated with this +# value and a value of TRUE is returned. Otherwise the return value is FALSE. +# +# Note that not in all invocations of this subroutine, gp_message() is +# operational. Only after the debug settings have been finalized, the +# messages are printed. +# +# This subroutine also generates warnings about multiple occurrences +# and the validity of the values. +#------------------------------------------------------------------------------ +sub extract_option_value +{ + my $subr_name = get_my_name (); + + my ($option_dir_ref, $max_occurrences_ref, $internal_option_name_ref, + $option_name_ref) = @_; + + my @option_dir = @{ $option_dir_ref }; + my $max_occurrences = ${ $max_occurrences_ref }; + my $internal_option_name = ${ $internal_option_name_ref }; + my $option_name = ${ $option_name_ref }; + + my $deprecated_option_used; + my $excess_occurrences; + my $msg; + my $no_of_occurrences; + my $no_of_warnings = 0; + my $option_value = "not set yet"; + my $option_value_missing; + my $option_value_missing_ref; + my $reset_blank_value; + my $special_treatment = $FALSE; + my $valid = $FALSE; + my $valid_ref; + + if (@option_dir) + { + $no_of_occurrences = scalar (@option_dir); + + $msg = "option_name = $option_name"; + gp_message ("debug", $subr_name, $msg); + $msg = "internal_option_name = $internal_option_name"; + gp_message ("debug", $subr_name, $msg); + $msg = "no_of_occurrences = $no_of_occurrences"; + gp_message ("debug", $subr_name, $msg); + + $excess_occurrences = ($no_of_occurrences > $max_occurrences) ? + $TRUE : $FALSE; + +#------------------------------------------------------------------------------ +# This is not supposed to happen, but just to be sure, there is a check. +#------------------------------------------------------------------------------ + if ($no_of_occurrences < 1) + { + $msg = "the number of fields is $no_of_occurrences"; + $msg .= " - should at least be 1"; + gp_message ("assertion", $subr_name, $msg); + } + +#------------------------------------------------------------------------------ +# For backward compatibility, we support the legacy "on" and "off" values for +# certain options. +# +# We also support the debug option without value. In case no value is given, +# it is set to "on". +# +# Note that regardless of the value(s) in ARGV, internally we use the on/off +# setting. +#------------------------------------------------------------------------------ + if (($g_user_settings{$internal_option_name}{"data_type"} eq "onoff") or + ($internal_option_name eq "debug")) + { + $msg = "enable special treatment of the option"; + gp_message ("debug", $subr_name, $msg); + + $special_treatment = $TRUE; + } + +#------------------------------------------------------------------------------ +# Issue a warning if the same option occcurs more often than what is supported. +#------------------------------------------------------------------------------ + if ($excess_occurrences) + { + $msg = "multiple occurrences of the " . $option_name . + " option found:"; + + gp_message ("debugM", $subr_name, $msg); + + gp_message ("warning", $subr_name, $g_html_new_line . $msg); + } + +#------------------------------------------------------------------------------ +# Main loop over all the occurrences of the options. This is a rather simple +# approach since only the last value seen will be accepted. +# +# To assist the user with troubleshooting, the values that are ignored will be +# checked for validity and a marker to this extent will be printed. +# +# NOTE: +# If an option may have multiple meaningful occurrences, this part needs to be +# revisited. +#------------------------------------------------------------------------------ + $deprecated_option_used = $FALSE; + for my $key (keys @option_dir) + { + $option_value = $option_dir[$key]; + $reset_blank_value = $FALSE; + +#------------------------------------------------------------------------------ +# For the "onoff" options, convert a blank value to "on". +#------------------------------------------------------------------------------ + if (($option_value eq "on") or ($option_value eq "off")) + { + if (($option_name eq "--verbose") or ($option_name eq "--quiet")) + { + $deprecated_option_used = $TRUE; + } + } + +#------------------------------------------------------------------------------ +# For the "onoff" options, convert a blank value to "on". +#------------------------------------------------------------------------------ + if ($special_treatment and ($option_value eq "")) + { + $option_value = "on"; + $reset_blank_value = $TRUE; + + $msg = "reset option value for $option_name from blank"; + $msg .= " to \"on\""; + gp_message ("debug", $subr_name, $msg); + } + +#------------------------------------------------------------------------------ +# Check for the option value to be valid. It may also happen that an option +# does not have a value, while it should have one. +#------------------------------------------------------------------------------ + ($valid_ref, $option_value_missing_ref) = check_and_set_user_option ( + $internal_option_name, + $option_value); + + $valid = ${ $valid_ref }; + $option_value_missing = ${ $option_value_missing_ref }; + + $msg = "option_value = $option_value"; + gp_message ("debug", $subr_name, $msg); + $msg = "after check_and_set_user_option: valid = $valid"; + $msg .= " option_value_missing = $option_value_missing"; + gp_message ("debug", $subr_name, $msg); + +#------------------------------------------------------------------------------ +# Generate warning messages, but if an option value is missing, it will also +# be considered to be a fatal error. +#------------------------------------------------------------------------------ + if ($excess_occurrences) + { + if ($option_value_missing) + { + $msg = "$option_name option - missing a value"; + } + else + { +#------------------------------------------------------------------------------ +# A little trick to avoid user confusion. Although we have set the internal +# value to "on", the user did not set this and so we print "" instead. +#------------------------------------------------------------------------------ + if ($reset_blank_value) + { + $msg = "$option_name option - value = \"\""; + } + else + { + $msg = "$option_name option - value = $option_value"; + } + $msg .= ($valid) ? " (valid value)" : " (invalid value)"; + } + + gp_message ("debug", $subr_name, $msg); + gp_message ("warning", $subr_name, $msg); + } + +#------------------------------------------------------------------------------ +# Check for the last occurrence of the option to be valid. If it is not, it +# is a fatal error. +#------------------------------------------------------------------------------ + if ((not $valid) && ($key == $no_of_occurrences-1)) + { + if ($option_value_missing) + { + $msg = "the $option_name option requires a value"; + } + else + { + $msg = "the value of $option_value for the $option_name"; + $msg .= " option is invalid"; + } + gp_message ("debug", $subr_name, $g_error_keyword . $msg); + + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + } + } + +#------------------------------------------------------------------------------ +# Issue a warning if the same option occcurs more often than what is supported +# and warn the user that all but the last value will be ignored. +#------------------------------------------------------------------------------ + if ($excess_occurrences) + { + $msg = "all values but the last one shown above are ignored"; + + gp_message ("debugM", $subr_name, $msg); + gp_message ("warning", $subr_name, $msg); + + $g_total_warning_count++; + } + } + +#------------------------------------------------------------------------------ +# Issue a warning if the old on/off syntax is used still. +#------------------------------------------------------------------------------ + if ($deprecated_option_used) + { + $msg = "<br>"; + $msg .= "the on/off syntax for option $option_name has been"; + $msg .= " deprecated"; + gp_message ("warning", $subr_name, $msg); + + $msg = "this option acts like a switch now"; + gp_message ("warning", $subr_name, $msg); + + $msg = "support for the old syntax may be terminated"; + $msg .= " in a future update"; + gp_message ("warning", $subr_name, $msg); + + $msg = "please check the man page of gp-display-html"; + $msg .= " for more details"; + gp_message ("warning", $subr_name, $msg); + $g_total_warning_count++; + } + + return (\$valid); + +} #-- End of subroutine extract_option_value + +#------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub extract_source_line_number @@ -3831,7 +4422,7 @@ sub extract_source_line_number my $line_id; #------------------------------------------------------------------------------ -# To extract the source line number, we need to distinguish whether this is +# 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); @@ -3874,7 +4465,55 @@ sub extract_source_line_number } #-- End of subroutine extract_source_line_number #------------------------------------------------------------------------------ -# For a give routine name and address, find the index into the +# Finalize the settings for the special options verbose, debug, warnings and +# quiet. +#------------------------------------------------------------------------------ +sub finalize_special_options +{ + my $subr_name = get_my_name (); + + my $msg; + +#------------------------------------------------------------------------------ +# If quiet mode has been enabled, disable verbose, warnings and debug. +#------------------------------------------------------------------------------ + if ($g_quiet) + { + $g_user_settings{"verbose"}{"current_value"} = "off"; + $g_user_settings{"nowarnings"}{"current_value"} = "on"; + $g_user_settings{"warnings"}{"current_value"} = "off"; + $g_user_settings{"debug"}{"current_value"} = "off"; + $g_debug = $FALSE; + $g_verbose = $FALSE; + $g_warnings = $FALSE; + my $debug_off = "off"; + my $ignore_value = set_debug_size (\$debug_off); + } + else + { +#------------------------------------------------------------------------------ +# Disable output buffering if verbose, debug, and/or warnings are enabled. +#------------------------------------------------------------------------------ + if ($g_verbose or $g_debug or $g_warnings) + { + STDOUT->autoflush (1); + + $msg = "enabled autoflush for STDOUT"; + gp_message ("debug", $subr_name, $msg); + } +#------------------------------------------------------------------------------ +# If verbose and/or debug have been enabled, print a message. +#------------------------------------------------------------------------------ +## gp_message ("verbose", $subr_name, "verbose mode has been enabled"); +## gp_message ("debug", $subr_name, "debug " . $g_debug_size_value . " mode has been enabled"); + } + + return (0); + +} #-- End of subroutine finalize_special_options + +#------------------------------------------------------------------------------ +# For a give routine name and address, find the index into the # function_info array #------------------------------------------------------------------------------ sub find_index_in_function_info @@ -3906,7 +4545,7 @@ sub find_index_in_function_info $addr_offset = $function_info[$ref_index]{"addressobjtext"}; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); - + $addr_offset =~ s/^@\d+://; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); if ($addr_offset eq $current_address) @@ -4030,7 +4669,7 @@ sub find_path_to_gp_display_text } } - return (\$error_occurred, \$return_value); + return (\$error_occurred, \$gp_path, \$return_value); } #-- End of subroutine find_path_to_gp_display_text @@ -4121,14 +4760,14 @@ sub find_words_in_line $start_word = $space_position; $end_word = $space - 1; $space_position = $space; - my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); + my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword"); push (@word_delimiters, [$start_word, $end_word]); } elsif ( ($space == $space_position) and ($space < length ($input_line) - 1)) { $space = $space + 1; - $space_position = $space; + $space_position = $space; } else { @@ -4142,7 +4781,7 @@ sub find_words_in_line $finished = $TRUE; $start_word = $space_position; $end_word = length ($input_line) - 1; - my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); + my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); push (@word_delimiters, [$start_word, $end_word]); if ($keyword =~ /\s+/) { @@ -4173,7 +4812,7 @@ sub find_words_in_line # TBD #------------------------------------------------------------------------------ sub function_info -{ +{ my $subr_name = get_my_name (); my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_; @@ -4185,7 +4824,7 @@ sub function_info my $full_address_field; my $FUNC_FILE_NO_PC; - my $off_with_the_PC; + my $off_with_the_PC; my $blanks; my $lblanks; @@ -4207,7 +4846,7 @@ sub function_info #------------------------------------------------------------------------------ my $length_of_string = length ($outputdir); - if (rindex ($outputdir, "/") != $length_of_string-1) + if (rindex ($outputdir, "/") != $length_of_string-1) { $outputdir .= "/"; } @@ -4224,12 +4863,12 @@ sub function_info $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"; @@ -4271,8 +4910,8 @@ sub function_info # er_print * before PC for calls ! 101315 #------------------------------------------------------------------------------ $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)"; - } - else + } + else { $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)"; } @@ -4307,8 +4946,8 @@ sub function_info gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7"); - } - else + } + else { $segment = $2; $offset = $4; @@ -4333,8 +4972,8 @@ sub function_info { $metric_value = $1; # whatever $routine = $2; - } - else + } + else { $routine = $1; } @@ -4348,7 +4987,7 @@ sub function_info for $vdso_key (keys %LINUX_vDSO) { if ($routine eq $LINUX_vDSO{$vdso_key}) - { + { #------------------------------------------------------------------------------ # presume no duplicates - at least can check offset #------------------------------------------------------------------------------ @@ -4362,7 +5001,7 @@ sub function_info #------------------------------------------------------------------------------ # the real segment #------------------------------------------------------------------------------ - $segment = $1; + $segment = $1; gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE"); $PC_Address = $segment.":".$offset; # PC Addr. gp_message ("debugXL", $subr_name, "vdso line ->$line"); @@ -4373,8 +5012,8 @@ sub function_info } } } - } - else + } + else { gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE"); } @@ -4417,13 +5056,13 @@ sub function_info } gp_message ("debugXL", $subr_name, "vdso line ->$line"); if (substr ($line,$lblanks+$lvdso_key,1) eq " ") - { + { #------------------------------------------------------------------------------ # O.K. no field abuttal #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line"); - } - else + } + else { gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line"); $line = $blanks.$vdso_key." ".$rest; @@ -4444,8 +5083,8 @@ sub function_info } $not_printed = $FALSE; } - } - else + } + else { if (!$pc_len) { @@ -4453,18 +5092,18 @@ sub function_info { $pc_len = length ($1); # say 15 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; - } - else + } + else { print FUNC_FILE_NO_PC "$line\n"; } - } - else + } + else { if ($pc_len) { my $strlen = length ($line); - if ($strlen > 0 ) + if ($strlen > 0 ) { print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; } @@ -4487,8 +5126,8 @@ sub function_info { $metric_value = $1; # whatever $routine = $2; - } - else + } + else { $routine = $1; } @@ -4513,8 +5152,8 @@ sub function_info if (not exists ($functions_per_metric_indexes{$routine})) { $functions_per_metric_indexes{$routine} = [$index_val]; - } - else + } + else { push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list } @@ -4536,21 +5175,21 @@ sub function_info { $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val; $u++; #$RI - } - else + } + else { if (!($metric eq "calls" || $metric eq "calltree")) { gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address"); } - } + } $index_val++; gp_message ("debugXL", $subr_name, "updated index_val = $index_val"); $n++; next; - } - else + } + else { if ($n && length ($line)) { @@ -4609,8 +5248,8 @@ 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, + 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 }; @@ -4640,10 +5279,10 @@ sub generate_caller_callee my $full_hex_address; my $hex_address; - my $file_title; - my $page_title; - my $size_text; - my $position_text; + my $file_title; + my $page_title; + my $size_text; + my $position_text; my @html_metric_sort_header = (); my $html_header; my $html_title_header; @@ -4651,17 +5290,17 @@ sub generate_caller_callee my $html_acknowledgement; my $html_end; my $html_line; - + my $marker_target_function; my $max_metrics_length = 0; - my $metrics_length; - my $modified_line; + my $metrics_length; + my $modified_line; my $name_regex; my $no_of_fields; my $routine; my $routine_length; - my $string_length; - my $top_header; + my $string_length; + my $top_header; my $total_header_lines; my $word_index_values_ref; my $infile; @@ -4678,7 +5317,7 @@ sub generate_caller_callee gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile"); - open (CALLER_CALLEE_IN, "<", $infile) + open (CALLER_CALLEE_IN, "<", $infile) or die ("unable to open caller file $infile for reading - '$!'"); gp_message ("debug", $subr_name, "opened file $infile for reading"); @@ -4696,10 +5335,10 @@ sub generate_caller_callee $html_home = ${ generate_home_link ("right") }; $page_title = "Caller Callee View"; - $size_text = "h2"; + $size_text = "h2"; $position_text = "center"; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; - + #------------------------------------------------------------------------------ # Read all of the file into array with the name caller_callee_data. #------------------------------------------------------------------------------ @@ -4712,14 +5351,14 @@ sub generate_caller_callee # 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 @@ -4730,7 +5369,7 @@ sub generate_caller_callee #------------------------------------------------------------------------------ # Scan the input file. The first lines are assumed to be part of the header, # so we store those. The diagnostic lines that echo some settings are also -# stored, but currently not used. +# stored, but currently not used. #------------------------------------------------------------------------------ my $scan_header = $FALSE; my $scan_caller_callee_data = $FALSE; @@ -4753,14 +5392,14 @@ sub generate_caller_callee my $get_addr_offset_regex = '^@\d+:'; #------------------------------------------------------------------------------ -# Get the length of the first metric field across all lines. This value is +# Get the length of the first metric field across all lines. This value is # used to pad the first metric with spaces and get the alignment right. # # Scan the input data and find the line(s) with metric values. A complication # is that a function name may consists of more than one field. # # Note. This part could be used to parse the other elements of the input file, -# but that makes the loop very complicated. Instead, we re-scan the data +# but that makes the loop very complicated. Instead, we re-scan the data # below and process each block separately. # # Since this data is all in memory and relatively small, the performance should @@ -4783,12 +5422,12 @@ sub generate_caller_callee { if (defined ($1) and defined ($2) and defined ($3)) #------------------------------------------------------------------------------ -# This is a line of interest, since it has the address, the function name and +# This is a line of interest, since it has the address, the function name and # the values for the metrics. Examples of valid lines are: # # 2:0x00005028 *xfree_large 0. 0 # 12:0x0004c2b0 munmap 0.143 6402086 -# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0 +# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0 # # The function name marked with a * is the current target. #------------------------------------------------------------------------------ @@ -4800,7 +5439,7 @@ sub generate_caller_callee if ($full_hex_address =~ /$get_hex_address_regex/) { $hex_address = "0x" . $2; - push (@hex_addresses, $hex_address); + push (@hex_addresses, $hex_address); gp_message ("debugXL", $subr_name, "pushed $hex_address"); } else @@ -4810,11 +5449,11 @@ sub generate_caller_callee } if ($marker eq "*") { - push (@special_marker, "*"); + push (@special_marker, "*"); } else { - push (@special_marker, "X"); + push (@special_marker, "X"); } } else @@ -4856,7 +5495,7 @@ sub generate_caller_callee gp_message ("debugXL", $subr_name, $txt); #------------------------------------------------------------------------------ -# Generate the regex for the metrics. +# Generate the regex for the metrics. # # TBD: This should be an attribute of the function and be done once only. #------------------------------------------------------------------------------ @@ -4880,8 +5519,8 @@ sub generate_caller_callee " its metrics = " . $its_metrics; gp_message ("debugXL", $subr_name, $msg); - push (@the_function_name, $func_name); - push (@the_metrics, $its_metrics); + push (@the_function_name, $func_name); + push (@the_metrics, $its_metrics); } else { @@ -4946,7 +5585,7 @@ sub generate_caller_callee gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block"); push (@function_blocks, $data_function_block); - my ($html_block_prologue_ref, $html_code_function_block_ref) = + my ($html_block_prologue_ref, $html_code_function_block_ref) = generate_html_function_blocks ( \$index_start, \$index_end, @@ -5067,16 +5706,16 @@ sub generate_caller_callee $no_of_fields = $#fields + 1; $elements_in_name = $no_of_fields - $number_of_metrics - 1; - + #------------------------------------------------------------------------------ # TBD: Too restrictive. # CHECK CODE IN GENERATE_CALLER_CALLEE #------------------------------------------------------------------------------ - if ($elements_in_name == 1) + if ($elements_in_name == 1) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)'; } - elsif ($elements_in_name == 2) + elsif ($elements_in_name == 2) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)'; } @@ -5094,11 +5733,11 @@ sub generate_caller_callee $full_hex_address = $1; $marker_target_function = $2; $routine = $3; - if ($elements_in_name == 1) + if ($elements_in_name == 1) { $all_metrics = $4; } - elsif ($elements_in_name == 2) + elsif ($elements_in_name == 2) { $all_metrics = $6; } @@ -5111,7 +5750,7 @@ sub generate_caller_callee $hex_address = "0x" . $2; } push (@marker, $marker_target_function); - push (@address_field, $hex_address); + push (@address_field, $hex_address); $modified_line = $all_metrics . " " . $routine; push (@metric_values, $all_metrics); gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); @@ -5165,7 +5804,7 @@ sub generate_caller_callee 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) @@ -5217,9 +5856,9 @@ sub generate_caller_callee 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 () }; @@ -5245,8 +5884,8 @@ 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, + 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 }; @@ -5265,43 +5904,43 @@ sub generate_dis_html my $hex_instruction_end; my @colour_line = (); - my $hot_line; - my $metric_values; + my $hot_line; + my $metric_values; my $src_line; - my $dec_instr_address; + my $dec_instr_address; my $instruction; my $operands; - + my $html_new_line = "<br>"; my $add_new_line_before; - my $add_new_line_after; - my $address_key; + my $add_new_line_after; + my $address_key; my $boldface; my $file; my $filename = $func; my $func_name; - my $orig_hex_instr_address; - my $hex_instr_address; + my $orig_hex_instr_address; + my $hex_instr_address; my $index_string; my $input_metric; my $linenumber; my $name; - my $last_address; - my $last_address_in_hex; + my $last_address; + my $last_address_in_hex; - my $file_title; + my $file_title; my $html_header; my $html_home; my $html_end; - - my $branch_regex = $g_arch_specific_settings{"regex"}; + + my $branch_regex = $g_arch_specific_settings{"regex"}; my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; my $linksubexp = $g_arch_specific_settings{"linksubexp"}; my $subexp = $g_arch_specific_settings{"subexp"}; - my $is_empty; + my $file_is_empty; my %branch_target = (); my %branch_target_no_ref = (); @@ -5315,14 +5954,14 @@ sub generate_dis_html my $extended_branch_target_ref; my $branch_target_no_ref_ref; - my $branch_address; - my $dec_branch_address; + my $branch_address; + my $dec_branch_address; my $found_it; my $found_it_ref; my $func_name_in_dis_file; my $hex_branch_target; - my $instruction_address; - my $instruction_offset; + my $instruction_address; + my $instruction_offset; my $link; my $modified_line; my $raw_hex_branch_target; @@ -5372,11 +6011,11 @@ sub generate_dis_html push (@modified_html, $html_header); push (@modified_html, $html_home); push (@modified_html, "<pre>"); - + #------------------------------------------------------------------------------ # Open the input and output files. #------------------------------------------------------------------------------ - open (INPUT_DISASSEMBLY, "<", $filename) + open (INPUT_DISASSEMBLY, "<", $filename) or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); gp_message ("debug", $subr_name , "opened file $filename for reading"); @@ -5387,8 +6026,8 @@ sub generate_dis_html #------------------------------------------------------------------------------ # Check if the file is empty #------------------------------------------------------------------------------ - $is_empty = is_file_empty ($filename); - if ($is_empty) + $file_is_empty = is_file_empty ($filename); + if ($file_is_empty) { #------------------------------------------------------------------------------ @@ -5444,18 +6083,18 @@ sub generate_dis_html @metrics = split (/$white_space_regex/ ,$1); $src_line_no = $2; } - else + else { my $msg = "$input_line has an unexpected format"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ -# Compute the maximum length of the first metric and pad the field from the +# Compute the maximum length of the first metric and pad the field from the # left later on. The fractional part is ignored. #------------------------------------------------------------------------------ my $first_metric = $metrics[0]; - my $new_length; + my $new_length; if ($first_metric =~ /$first_integer_regex/) { $new_length = length ($first_metric); @@ -5477,20 +6116,20 @@ sub generate_dis_html #------------------------------------------------------------------------------ { $source_line[$line_no] = $src_line_no; - my $msg; - $msg = "found an instruction with a source line ref: "; - $msg .= "source_line[$line_no] = $source_line[$line_no]"; + my $msg; + $msg = "found an instruction with a source line ref:"; + $msg .= " source_line[$line_no] = $source_line[$line_no]"; gp_message ("debugXL", $subr_name, $msg); } - + #------------------------------------------------------------------------------ -# Check for function calls. If found, get the address offset from $4 and +# Check for function calls. If found, get the address offset from $4 and # compute the target address. #------------------------------------------------------------------------------ - ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) = + ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) = check_and_proc_dis_func_call ( \$input_line, - \$line_no, + \$line_no, \%branch_target, \%extended_branch_target); $found_it = ${ $found_it_ref }; @@ -5509,7 +6148,7 @@ sub generate_dis_html ($found_it_ref, $branch_target_ref, $extended_branch_target_ref, $branch_target_no_ref_ref) = check_and_proc_dis_branches ( \$input_line, - \$line_no, + \$line_no, \%branch_target, \%extended_branch_target, \%branch_target_no_ref); @@ -5580,7 +6219,7 @@ sub generate_dis_html # In both cases, the first line after the header has whitespace. This is # followed by: # -# - A source line file has "<line_no>." +# - A source line file has "<line_no>." # - A dissasembly file has "<Function:" # # These are the characteristics we use below. @@ -5602,7 +6241,6 @@ sub generate_dis_html last; } push (@modified_html, "<i>" . $input_line . "</i>"); - } my $line_index = scalar (@modified_html); gp_message ("debugXL", $subr_name, "final line_index = $line_index"); @@ -5663,20 +6301,20 @@ sub generate_dis_html } for my $row (keys @hot_program_counters) { - my $msg = "$filename row[" . $row . "] = "; + my $msg = "$filename row[" . $row . "] ="; for my $col (keys @{$hot_program_counters[$row]}) { - $msg .= "$hot_program_counters[$row][$col] "; - $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col]; + $msg .= " $hot_program_counters[$row][$col]"; + $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col]; } gp_message ("debugXL", $subr_name, "hot PC = $msg"); } for my $row (keys @transposed_hot_pc) { - my $msg = "$filename row[" . $row . "] = "; + my $msg = "$filename row[" . $row . "] ="; for my $col (keys @{$transposed_hot_pc[$row]}) { - $msg .= "$transposed_hot_pc[$row][$col] "; + $msg .= " $transposed_hot_pc[$row][$col]"; } gp_message ("debugXL", $subr_name, "$filename transposed = $msg"); } @@ -5689,7 +6327,7 @@ sub generate_dis_html my $max_val = 0; for my $col (0 .. $#{$transposed_hot_pc[$row]}) { - $max_val = max ($transposed_hot_pc[$row][$col], $max_val);; + $max_val = max ($transposed_hot_pc[$row][$col], $max_val); } if ($max_val =~ /$integer_regex/) { @@ -5738,7 +6376,7 @@ sub generate_dis_html if (defined ($dec_instruction_start)) { - if ($dec_instr_address < $dec_instruction_start) + if ($dec_instr_address < $dec_instruction_start) { $dec_instruction_start = $dec_instr_address; } @@ -5749,7 +6387,7 @@ sub generate_dis_html } if (defined ($dec_instruction_end)) { - if ($dec_instr_address > $dec_instruction_end) + if ($dec_instr_address > $dec_instruction_end) { $dec_instruction_end = $dec_instr_address; } @@ -5812,7 +6450,7 @@ sub generate_dis_html #------------------------------------------------------------------------------ # Pad the line with the metrics to ensure correct alignment. #------------------------------------------------------------------------------ - my $the_length; + my $the_length; my @split_metrics = split (" ", $metric_values); my $first_metric = $split_metrics[0]; ## if ($first_metric =~ /^\d+$/) @@ -5837,7 +6475,7 @@ sub generate_dis_html #------------------------------------------------------------------------------ # Since the instruction address variable may change and because we need the -# original address without html controls, we use a new variable for the +# original address without html controls, we use a new variable for the # (potentially) modified address. #------------------------------------------------------------------------------ $hex_instr_address = $orig_hex_instr_address; @@ -5870,7 +6508,7 @@ sub generate_dis_html # Mark control flow instructions. Several cases need to be distinguished. # # In all cases we give the instruction a specific color, mark it boldface -# and add a new-line after the instruction +# and add a new-line after the instruction #------------------------------------------------------------------------------ if ( ($instruction =~ /$control_flow_1_regex/) or ($instruction =~ /$control_flow_2_regex/) or @@ -5928,7 +6566,7 @@ sub generate_dis_html } ## if (exists ($inverse_branch_target{$hex_instr_address}) or ## exists ($branch_target_no_ref{$hex_instr_address})) - if (exists ($inverse_branch_target{$hex_instr_address})) + if (exists ($inverse_branch_target{$hex_instr_address})) #------------------------------------------------------------------------------ # This is a target address and we need to define the instruction address to be # a label. @@ -5951,13 +6589,13 @@ sub generate_dis_html gp_message ("debugXL", $subr_name, "final modified_line = $modified_line"); #------------------------------------------------------------------------------ -# This is a control flow instruction, but it is the last one and we do not +# This is a control flow instruction, but it is the last one and we do not # want to add a newline. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html"); gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after"); gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before"); - + if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) ) { $add_new_line_after = $FALSE; @@ -6006,7 +6644,7 @@ sub generate_dis_html #------------------------------------------------------------------------------ { $modified_line = set_background_color_string ( - $modified_line, + $modified_line, $g_html_color_scheme{"background_color_hot"}); } #------------------------------------------------------------------------------ @@ -6017,7 +6655,7 @@ sub generate_dis_html my @current_metrics = split (" ", $metric_values); for my $metric (0 .. $#current_metrics) { - my $current_value; + my $current_value; my $max_value; $current_value = $current_metrics[$metric]; #------------------------------------------------------------------------------ @@ -6041,7 +6679,7 @@ sub generate_dis_html gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line"); $modified_line = set_background_color_string ( - $modified_line, + $modified_line, $g_html_color_scheme{"background_color_lukewarm"}); last; } @@ -6105,15 +6743,15 @@ sub generate_dis_html my $spaces = $1; my $boldface = $TRUE; gp_message ("debugXL", $subr_name, "function_name = $2"); - my $function_line = "<Function: " . $func_name_in_dis_file . ">"; + my $function_line = "<Function: " . $func_name_in_dis_file . ">"; -##### HACK +##### HACK if ($func_name_in_dis_file eq $target_function) { my $color_function_name = color_string ( - $function_line, - $boldface, + $function_line, + $boldface, $g_html_color_scheme{"target_function_name"}); my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>"; $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>"; @@ -6121,8 +6759,8 @@ sub generate_dis_html else { my $color_function_name = color_string ( - $function_line, - $boldface, + $function_line, + $boldface, $g_html_color_scheme{"non_target_function_name"}); $html_name = "<i>" . $spaces . $color_function_name . "</i>"; } @@ -6141,14 +6779,17 @@ sub generate_dis_html # # TBD: The same is done in process_source but should be done only once. #------------------------------------------------------------------------------ - if ($hp_value > 0) + if ($hp_value > 0) { my $rounded_percentage = sprintf ("%.1f", $hp_value); - $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; + $threshold_line = "<i>The setting for the highlight percentage"; + $threshold_line .= " (--highlight-percentage) option:"; + $threshold_line .= " " . $rounded_percentage . " (%)</i>"; } else { - $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; + $threshold_line = "<i>The highlight percentage feature has not been"; + $threshold_line .= " enabled</i>"; } $html_home = ${ generate_home_link ("left") }; @@ -6193,7 +6834,7 @@ sub generate_function_level_info { my $subr_name = get_my_name (); - my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string, + my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string, $sort_fields_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; @@ -6234,7 +6875,7 @@ sub generate_function_level_info gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files"); - open (SCRIPT_PC, ">", $script_file_PC) + open (SCRIPT_PC, ">", $script_file_PC) or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'"); gp_message ("debug", $subr_name, "opened file $script_file_PC for writing"); @@ -6269,20 +6910,20 @@ sub generate_function_level_info #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ - print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; - print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; + print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; + print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; #------------------------------------------------------------------------------ # Not really sorted #------------------------------------------------------------------------------ - print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; - print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; + print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; + print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; - print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; - print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; + print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; + print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; print SCRIPT_PC "metrics address:name:$summary_metrics\n"; print SCRIPT_PC "# sort $first_metric\n"; @@ -6298,8 +6939,8 @@ sub generate_function_level_info #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ - print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; - print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; + print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; + print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n"; @@ -6331,8 +6972,8 @@ sub generate_function_level_info #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ - print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; - print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; + print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; + print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; $script_pc_metrics = "address:$call_metrics"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; @@ -6340,8 +6981,8 @@ sub generate_function_level_info #------------------------------------------------------------------------------ # Not really sorted #------------------------------------------------------------------------------ - print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; - print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; + print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; + print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; #------------------------------------------------------------------------------ # Get caller-callee list @@ -6416,18 +7057,18 @@ sub generate_function_level_info if ($error_code != 0) { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); - gp_message ("abort", "execution terminated"); + gp_message ("abort", $subr_name, "execution terminated"); } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Parse the full function view and store the data. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my @input_data = (); my $empty_line_regex = '^\s*$'; - + ## my $full_function_view = $outputdir . "functions.full"; open (ALL_FUNC_DATA, "<", $full_function_view) @@ -6440,7 +7081,7 @@ sub generate_function_level_info 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+(.*)/) { @@ -6456,7 +7097,7 @@ sub generate_function_level_info 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; @@ -6491,8 +7132,8 @@ 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, + 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 }; @@ -6506,48 +7147,48 @@ sub generate_function_view my %addressobjtextm = %{ $addressobjtextm_ref }; my @abs_path_exp_dirs = (); - my @experiment_directories; + my @experiment_directories; - my $target_function; + my $target_function; my $html_line; my $ftag; - my $routine_length; + my $routine_length; my %html_source_functions = (); - my $href_link; + my $href_link; my $infile; my $input_experiments; - my $keep_value; - my $loadobj; - my $address_field; - my $address_offset; + my $keep_value; + my $loadobj; + my $address_field; + my $address_offset; my $msg; - my $exe; - my $extra_field; + my $exe; + my $extra_field; my $new_target_function; - my $file_title; - my $html_output_file; - my $html_function_view; - my $overview_file; - my $exp_name; - my $exp_type; + my $file_title; + my $html_output_file; + my $html_function_view; + my $overview_file; + my $exp_name; + my $exp_type; my $html_header; - my $routine; - my $length_header; + my $routine; + my $length_header; my $length_metrics; - my $full_index_line; - my $acknowledgement; + my $full_index_line; + my $acknowledgement; my @full_function_view_line = (); my $spaces; - my $size_text; - my $position_text; - my $html_first_metric_file; + my $size_text; + my $position_text; + my $html_first_metric_file; my $html_new_line = "<br>"; - my $html_acknowledgement; + my $html_acknowledgement; my $html_end; - my $html_home; - my $page_title; - my $html_title_header; + my $html_home; + my $page_title; + my $html_title_header; my $outputdir = append_forward_slash ($directory_name); my $LANG = $g_locale_settings{"LANG"}; @@ -6590,7 +7231,7 @@ sub generate_function_view gp_message ("assertion", $subr_name, $msg); } - $html_source_functions{$target_function} = $function_info[$i]{"html function block"}; + $html_source_functions{$target_function} = $function_info[$i]{"html function block"}; } for my $i (sort keys %html_source_functions) @@ -6607,7 +7248,7 @@ sub generate_function_view # 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 @@ -6635,7 +7276,7 @@ sub generate_function_view } #------------------------------------------------------------------------------ # The default function view is based upon the first metric in the list. We use -# this file in the index.html file. +# this file in the index.html file. #------------------------------------------------------------------------------ if ($metric eq $g_first_metric) { @@ -6647,7 +7288,7 @@ sub generate_function_view $html_output_file = $outputdir . $html_function_view; - open (FUNCTION_VIEW, ">", $html_output_file) + open (FUNCTION_VIEW, ">", $html_output_file) or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); @@ -6655,7 +7296,7 @@ sub generate_function_view $html_header = ${ create_html_header (\$file_title) }; $page_title = "Function View"; - $size_text = "h2"; + $size_text = "h2"; $position_text = "center"; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; @@ -6666,12 +7307,12 @@ sub generate_function_view print FUNCTION_VIEW $html_new_line . "\n"; my $function_view_structure_ref = process_function_overview ( - \$metric, - \$exp_type, - \$summary_metrics, - \$number_of_metrics, - \@function_info, - \%function_view_structure, + \$metric, + \$exp_type, + \$summary_metrics, + \$number_of_metrics, + \@function_info, + \%function_view_structure, \$overview_file); my %function_view_structure = %{ $function_view_structure_ref }; @@ -6680,11 +7321,11 @@ sub generate_function_view # Core part: extract the true function name and find the html code for it. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "the final table"); - + print FUNCTION_VIEW "<pre>\n"; print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} }; - my $max_length_header = $function_view_structure{"max header length"}; + my $max_length_header = $function_view_structure{"max header length"}; my $max_length_metrics = $function_view_structure{"max metrics length"}; #------------------------------------------------------------------------------ @@ -6704,9 +7345,8 @@ sub generate_function_view my $func_header = $spaces . $function_view_structure{"table name"}; gp_message ("debugXL", $subr_name, "func_header = " . $func_header); - - print FUNCTION_VIEW $spaces . "<b>" . - $function_view_structure{"table name"} . + print FUNCTION_VIEW $spaces . "<b>" . + $function_view_structure{"table name"} . "</b>" . $html_new_line . "\n"; #------------------------------------------------------------------------------ @@ -6742,14 +7382,14 @@ sub generate_function_view 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 () }; @@ -6763,7 +7403,7 @@ sub generate_function_view close (FUNCTION_VIEW); } - return (\$html_first_metric_file); + return (\$html_first_metric_file); } #-- End of subroutine generate_function_view @@ -6777,7 +7417,7 @@ sub generate_home_link my ($which_side) = @_; - my $html_home_line; + my $html_home_line; if (($which_side ne "left") and ($which_side ne "right")) { @@ -6786,8 +7426,8 @@ sub generate_home_link } $html_home_line .= "<div class=\"" . $which_side . "\">"; - $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"}; - $html_home_line .= ".html' style='background-color:"; + $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"}; + $html_home_line .= ".html' style='background-color:"; $html_home_line .= $g_html_color_scheme{"index"}; $html_home_line .= "'><b>Return to main view</b></a>"; $html_home_line .= "</div>"; @@ -6811,11 +7451,11 @@ sub generate_html_function_blocks $length_first_metric_ref, $special_marker_ref, $the_function_name_ref, - $separator_ref, - $number_of_metrics_ref, - $data_function_block_ref, - $function_info_ref, - $function_view_structure_ref) = @_; + $separator_ref, + $number_of_metrics_ref, + $data_function_block_ref, + $function_info_ref, + $function_view_structure_ref) = @_; my $index_start = ${ $index_start_ref }; my $index_end = ${ $index_end_ref }; @@ -6831,7 +7471,7 @@ sub generate_html_function_blocks my @function_info = @{ $function_info_ref }; my %function_view_structure = %{ $function_view_structure_ref }; - my $decimal_separator = $g_locale_settings{"decimal_separator"}; + my $decimal_separator = $g_locale_settings{"decimal_separator"}; my @html_block_prologue = (); my @html_code_function_block = (); @@ -6845,33 +7485,33 @@ sub generate_html_function_blocks my @split_number = (); my @function_tags = (); - my $all_metrics; + my $all_metrics; my $current_function_name; my $no_of_fields; my $name_regex; my $full_hex_address; my $hex_address; - my $target_function; - my $marker_function; - my $routine; - my $routine_length; - my $metrics_length; + my $target_function; + my $marker_function; + my $routine; + my $routine_length; + my $metrics_length; my $max_metrics_length = 0; my $modified_line; - my $string_length; - my $addr_offset; - my $current_address; + my $string_length; + my $addr_offset; + my $current_address; my $found_a_match; my $ref_index; my $alt_name; - my $length_first_field; + my $length_first_field; my $gap; - my $ipad; - my $html_line; - my $target_tag; - my $tag_for_header; - my $href_file; - my $found_alt_name; + my $ipad; + my $html_line; + my $target_tag; + my $tag_for_header; + my $href_file; + my $found_alt_name; my $name_in_header; my $create_hyperlinks; @@ -6937,7 +7577,7 @@ sub generate_html_function_blocks { my $decimal_point = $decimal_separator; $decimal_point =~ s/\\//; - my $txt = "input_line = $input_line = ended with 0"; + my $txt = "input_line = $input_line = ended with 0"; $txt .= $decimal_point; gp_message ("debugXL", $subr_name, $txt); @@ -6958,16 +7598,16 @@ sub generate_html_function_blocks $max_metrics_length = max ($max_metrics_length, $metrics_length); push (@marker, $marker_function); - push (@address_field, $hex_address); + push (@address_field, $hex_address); push (@metric_values, $all_metrics); push (@function_names, $routine); my $index_into_function_info_ref = get_index_function_info ( - \$routine, - \$hex_addresses[$i], + \$routine, + \$hex_addresses[$i], $function_info_ref); - my $index_into_function_info = ${ $index_into_function_info_ref }; + my $index_into_function_info = ${ $index_into_function_info_ref }; $target_tag = $function_info[$index_into_function_info]{"tag_id"}; $alt_name = $function_info[$index_into_function_info]{"alt_name"}; @@ -7044,11 +7684,11 @@ sub generate_html_function_blocks if ($marker[$i] eq "*") { - $html_line = "<br>" . $html_line; + $html_line = "<br>" . $html_line; } elsif (($marker[$i] ne "*") and ($i == 0)) { - $html_line = "<br>" . $html_line; + $html_line = "<br>" . $html_line; } gp_message ("debugXL", $subr_name, "html_line = $html_line"); @@ -7059,7 +7699,7 @@ sub generate_html_function_blocks $routine = $function_names[$i]; $current_address = $address_field[$i]; - my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info); + my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info); my $target_index = ${ $target_index_ref }; gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index"); @@ -7068,7 +7708,7 @@ sub generate_html_function_blocks # TBD Do this once for each function and store the result. This is a saving # because functions may and typically will appear more than once. #------------------------------------------------------------------------------ - my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"}; + my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"}; #------------------------------------------------------------------------------ # Add the links to the line. Make sure there is at least one space. @@ -7087,7 +7727,7 @@ sub generate_html_function_blocks $html_line .= $function_info[$target_index]{"href_disassembly"}; } - push (@html_code_function_block, $html_line); + push (@html_code_function_block, $html_line); } for my $lines (0 .. $#html_code_function_block) @@ -7095,192 +7735,12 @@ sub generate_html_function_blocks gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]); } - return (\@html_block_prologue, \@html_code_function_block); + return (\@html_block_prologue, \@html_code_function_block); } #-- End of subroutine generate_html_function_blocks #------------------------------------------------------------------------------ -# Generate the index.html file. -#------------------------------------------------------------------------------ -sub generate_index -{ - my $subr_name = get_my_name (); - - my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, - $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, - $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, - $metric_description_reversed_ref, $number_of_warnings_ref, - $table_execution_stats_ref) = @_; - - my $outputdir = ${ $outputdir_ref }; - my $html_first_metric_file = ${ $html_first_metric_file_ref }; - my $summary_metrics = ${ $summary_metrics_ref }; - my $number_of_metrics = ${ $number_of_metrics_ref }; - my @function_info = @{ $function_info_ref }; - my %function_address_info = %{ $function_address_info_ref }; - my @sort_fields = @{ $sort_fields_ref }; - my @exp_dir_list = @{ $exp_dir_list_ref }; - my %addressobjtextm = %{ $addressobjtextm_ref }; - my %metric_description_reversed = %{ $metric_description_reversed_ref }; - my $number_of_warnings = ${ $number_of_warnings_ref }; - my @table_execution_stats = @{ $table_execution_stats_ref }; - - my @file_contents = (); - - my $acknowledgement; - my @abs_path_exp_dirs = (); - my $input_experiments; - my $target_function; - my $html_line; - my $ftag; - my $max_length = 0; - my %html_source_functions = (); - my $html_header; - my @experiment_directories = (); - my $html_acknowledgement; - my $html_file_title; - my $html_output_file; - my $html_function_view; - my $html_caller_callee_view; - my $html_experiment_info; - my $html_warnings_page; - my $href_link; - my $file_title; - my $html_gprofng; - my $html_end; - my $max_length_metrics; - my $page_title; - my $size_text; - my $position_text; - - my $ln; - my $base; - my $base_index_page; - my $infile; - my $outfile; - my $rec; - my $skip; - my $callsize; - my $dest; - my $final_string; - my @headers; - my $header; - my $sort_index; - my $pc_address; - my $anchor; - my $directory_name; - my $f2; - my $f3; - my $file; - my $sline; - my $src; - my $srcfile_name; - my $tmp1; - my $tmp2; - my $fullsize; - my $regf2; - my $trimsize; - my $EIL; - my $EEIL; - my $AOBJ; - my $RI; - my $HDR; - my $CALLER_CALLEE; - my $NAME; - my $SRC; - my $TRIMMED; - -#------------------------------------------------------------------------------ -# Add a forward slash to make it easier when creating file names. -#------------------------------------------------------------------------------ - $outputdir = append_forward_slash ($outputdir); - gp_message ("debug", $subr_name, "outputdir = $outputdir"); - - my $LANG = $g_locale_settings{"LANG"}; - my $decimal_separator = $g_locale_settings{"decimal_separator"}; - - $input_experiments = join (", ", @exp_dir_list); - - for my $i (0 .. $#exp_dir_list) - { - my $dir = get_basename ($exp_dir_list[$i]); - push @abs_path_exp_dirs, $dir; - } - $input_experiments = join (", ", @abs_path_exp_dirs); - - gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); - -#------------------------------------------------------------------------------ -# TBD: Pass in the values for $expr_name and $cmd -#------------------------------------------------------------------------------ - $html_file_title = "Main index page"; - - @experiment_directories = split (",", $input_experiments); - $html_acknowledgement = ${ create_html_credits () }; - - $html_end = ${ terminate_html_document () }; - - $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html"; - - open (INDEX, ">", $html_output_file) - or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); - gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); - - $page_title = "GPROFNG Performance Analysis"; - $size_text = "h1"; - $position_text = "center"; - $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; - - $html_header = ${ create_html_header (\$html_file_title) }; - - print INDEX $html_header; - print INDEX $html_gprofng; - print INDEX "$_" for @g_html_experiment_stats; - print INDEX "$_" for @table_execution_stats; - - $html_experiment_info = "<a href=\'"; - $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html"; - $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n"; - - $html_warnings_page = "<a href=\'"; - $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html"; - $html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n"; - - $html_function_view = "<a href=\'"; - $html_function_view .= $html_first_metric_file; - $html_function_view .= "\'><h3>Function View</h3></a>\n"; - - $html_caller_callee_view = "<a href=\'"; - $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html"; - $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n"; - - print INDEX "<br>\n"; -## print INDEX "<b>\n"; - print INDEX $html_experiment_info; - print INDEX $html_warnings_page;; -## print INDEX "<br>\n"; -## print INDEX "<br>\n"; - print INDEX $html_function_view; -## print INDEX "<br>\n"; -## print INDEX "<br>\n"; - print INDEX $html_caller_callee_view; -## print INDEX "</b>\n"; -## print INDEX "<br>\n"; -## print INDEX "<br>\n"; - - print INDEX $html_acknowledgement; - print INDEX $html_end; - - close (INDEX); - - gp_message ("debug", $subr_name, "closed file $html_output_file"); - - return (0); - -} #-- End of subroutine generate_index - -#------------------------------------------------------------------------------ -# Get all the metrics available +# Get all the metrics available # # (gp-display-text) metric_list # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name @@ -7312,8 +7772,8 @@ sub get_all_the_metrics my $outputdir = ${ $outputdir_ref }; my $ignore_value; - my $gp_functions_cmd; - my $gp_display_text_cmd; + my $gp_functions_cmd; + my $gp_display_text_cmd; my $metrics_output_file = $outputdir . "metrics-all"; my $result_file = $outputdir . $g_gp_output_file; @@ -7322,7 +7782,7 @@ sub get_all_the_metrics my @metrics_data = (); - open (SCRIPT_METRICS, ">", $script_file_metrics) + open (SCRIPT_METRICS, ">", $script_file_metrics) or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing"); @@ -7344,13 +7804,13 @@ sub get_all_the_metrics if ($error_code != 0) { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } - open (METRICS_INFO, "<", $metrics_output_file) + open (METRICS_INFO, "<", $metrics_output_file) or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading"); @@ -7419,7 +7879,7 @@ sub get_basename } #-- End of subroutine get_basename #------------------------------------------------------------------------------ -# Get the details on the experiments and store these in a file. Each +# Get the details on the experiments and store these in a file. Each # experiment has its own file. This makes the processing easier. #------------------------------------------------------------------------------ sub get_experiment_info @@ -7434,14 +7894,15 @@ sub get_experiment_info my $cmd_output; my $current_slot; my $error_code; - my $exp_info_file; + my $exp_info_file; my @exp_info = (); my @experiment_data = (); my $gp_error_file; my $gp_display_text_cmd; - my $gp_functions_cmd; - my $gp_log_file; + my $gp_functions_cmd; + my $gp_log_file; my $ignore_value; + my $msg; my $overview_file; my $result_file; my $script_file; @@ -7455,7 +7916,7 @@ sub get_experiment_info $gp_log_file = $outputdir . $g_gp_output_file; $gp_error_file = $outputdir . $g_gp_error_logfile; - open (SCRIPT_EXPERIMENT_INFO, ">", $script_file) + open (SCRIPT_EXPERIMENT_INFO, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); @@ -7485,29 +7946,29 @@ sub get_experiment_info if ($error_code != 0) { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The first file has the following format: # # ID Sel PID Experiment # == === ======= ====================================================== # 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er # 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er -#------------------------------------------------------------------------------- - open (EXP_INFO, "<", $exp_info_file) +#------------------------------------------------------------------------------ + open (EXP_INFO, "<", $exp_info_file) or die ("$subr_name - unable to open file $exp_info_file for reading '$!'"); gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading"); chomp (@exp_info = <EXP_INFO>); -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # TBD - Check for the groups to exist below: -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ $current_slot = 0; for my $i (0 .. $#exp_info) { @@ -7532,21 +7993,21 @@ sub get_experiment_info } else { - my $msg = "remainder = $remainder has an unexpected format"; + $msg = "remainder = $remainder has an unexpected format"; gp_message ("assertion", $subr_name, $msg); } } } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The experiment IDs and names are known. We can now generate the info for # each individual experiment. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ $gp_log_file = $outputdir . $g_gp_output_file; $gp_error_file = $outputdir . $g_gp_error_logfile; $script_file = $outputdir . "gp-details-exp.script"; - open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file) + open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); @@ -7571,19 +8032,20 @@ sub get_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 details"); + $msg = "executing $GP_DISPLAY_TEXT to get the experiment details"; + gp_message ("debug", $subr_name, $msg); $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # This is unlikely to happen, but you never know. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } @@ -7649,13 +8111,13 @@ sub getfilesize } #-- End of subroutine getfilesize #------------------------------------------------------------------------------ -# Parse the fsummary output and for all functions, store all the information -# found in "function_info". In addition to this, several derived structures +# Parse the fsummary output and for all functions, store all the information +# found in "function_info". In addition to this, several derived structures # are stored as well, making this structure a "onestop" place to get all the # info that is needed. #------------------------------------------------------------------------------ sub get_function_info -{ +{ my $subr_name = get_my_name (); my ($FSUMMARY_FILE) = @_; @@ -7675,6 +8137,8 @@ sub get_function_info #------------------------------------------------------------------------------ my %functions_index = (); + my $msg; + # TBD: check my $full_address_field; my %source_files = (); @@ -7705,7 +8169,7 @@ sub get_function_info # # 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%) @@ -7716,14 +8180,14 @@ sub get_function_info # Load Object: <Total> # Mangled Name: # Aliases: -# +# # a_function_name # Exclusive Total CPU Time: 4.003 ( 34.7%) # Inclusive Total CPU Time: 4.003 ( 34.7%) # Size: 715 # PC Address: 2:0x00006c61 -# Source File: <absolute path to source file> -# Object File: <object filename> +# Source File: <absolute path to source file> +# Object File: <object filename> # Load Object: <executable name> # Mangled Name: # Aliases: @@ -7819,8 +8283,8 @@ sub get_function_info { $g_multi_count_function{$routine} = $TRUE; } - my $msg = "g_function_occurrences{$routine} = " . - $g_function_occurrences{$routine}; + $msg = "g_function_occurrences{$routine} = "; + $msg .= $g_function_occurrences{$routine}; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -7845,14 +8309,14 @@ sub get_function_info gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"}); #------------------------------------------------------------------------------ -# The $functions_index hash contains an array. After an initial assignment, +# The $functions_index hash contains an array. After an initial assignment, # other values that have been found are pushed onto the arrays. #------------------------------------------------------------------------------ if (not exists ($functions_index{$routine})) { $functions_index{$routine} = [$i]; - } - else + } + else { #------------------------------------------------------------------------------ # Add the array index to the list @@ -7900,7 +8364,7 @@ sub get_function_info } else { - my $msg = "unexpected: number of fields = " . $no_of_elements; + $msg = "unexpected: number of fields = " . $no_of_elements; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -7930,7 +8394,7 @@ sub get_function_info my $offset; #------------------------------------------------------------------------------ # The format of the address is assumed to be the following 2:0x000070a8 -# Note that the regex is pretty wide. This is from the original code and +# Note that the regex is pretty wide. This is from the original code and # could be made more specific: # if ($value =~ /\s*(\S+):(\S+)/) #------------------------------------------------------------------------------ @@ -7945,8 +8409,9 @@ sub get_function_info $address_decimal = bigint::hex ($offset); # decimal #------------------------------------------------------------------------------ # Construct the address field. Note that we use the hex address here. +# For example @2:0x0003f280 #------------------------------------------------------------------------------ - $full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280 + $full_address_field = '@'.$segment.":0x".$offset; $function_info[$i]{"addressobj"} = $address_decimal; $function_info[$i]{"addressobjtext"} = $full_address_field; @@ -7956,29 +8421,31 @@ sub get_function_info { $function_address_and_index{$routine}{$value} = $i; - my $msg = "function_address_and_index{$routine}{$value} = " . - $function_address_and_index{$routine}{$value}; + $msg = "function_address_and_index{$routine}{$value} = "; + $msg .= $function_address_and_index{$routine}{$value}; gp_message ("debugXL", $subr_name, $msg); - } - else + } + else { - gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address"); - } + $msg = "function_info: $FSUMMARY_FILE: function $routine"; + $msg .= " already has a PC Address"; + gp_message ("debugXL", $subr_name, $msg); + } $number_of_functions++; } } close (FSUMMARY_FILE); - + #------------------------------------------------------------------------------ # For every function in the function overview, set up an html structure with # the various hyperlinks. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "augment function_info with alt_name"); - my $target_function; + my $target_function; my $html_line; my $ftag; - my $routine_length; + my $routine_length; my %html_source_functions = (); for my $i (keys @function_info) { @@ -8021,7 +8488,7 @@ sub get_function_info #------------------------------------------------------------------------------ my $loadobj = $function_info[$i]{"Load Object"}; my $address_field = $function_info[$i]{"addressobjtext"}; - my $address_offset; + my $address_offset; #------------------------------------------------------------------------------ # The address field has the following format: @<n>:<address_offset> @@ -8058,14 +8525,14 @@ sub get_function_info gp_message ("debug", $subr_name, "augment function_info with alt_name completed"); #------------------------------------------------------------------------------ -# Compute the maximum function name length. +# Compute the maximum function name length. # # The maximum length is stored in %function_view_structure. #------------------------------------------------------------------------------ my $max_function_length = 0; for my $i (0 .. $#function_info) { - $max_function_length = max ($max_function_length, $function_info[$i]{"function length"}); + $max_function_length = List::Util::max ($max_function_length, $function_info[$i]{"function length"}); gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"}); } @@ -8087,7 +8554,7 @@ sub get_function_info my $top_of_table = $FALSE; for my $i (keys @function_info) { - my $new_target_function; + my $new_target_function; if (defined ($function_info[$i]{"alt_name"})) { @@ -8111,7 +8578,7 @@ sub get_function_info if ($target_function eq "<Total>") #------------------------------------------------------------------------------ # <Total> is a pseudo function and there is no source, or disassembly for it. -# We could add a link to the caller-callee part, but this is currently not +# We could add a link to the caller-callee part, but this is currently not # done. #------------------------------------------------------------------------------ { @@ -8143,7 +8610,7 @@ sub get_function_info } #------------------------------------------------------------------------------ -# Create the block with the function name, in boldface, plus the links to the +# Create the block with the function name, in boldface, plus the links to the # source, disassembly and caller-callee views. #------------------------------------------------------------------------------ @@ -8158,7 +8625,8 @@ sub get_function_info $html_line .= $function_info[$i]{"href_caller_callee"}; } - gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line"); + $msg = "target_function = $target_function html_line = $html_line"; + gp_message ("debugM", $subr_name, $msg); $html_source_functions{$target_function} = $html_line; #------------------------------------------------------------------------------ @@ -8169,11 +8637,14 @@ sub get_function_info for my $i (keys %html_source_functions) { - gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); + $msg = "html_source_functions{$i} = $html_source_functions{$i}"; + gp_message ("debugM", $subr_name, $msg); } for my $i (keys @function_info) { - gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"}); + $msg = "function_info[$i]{\"html function block\"} = "; + $msg .= $function_info[$i]{"html function block"}; + gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -8183,7 +8654,9 @@ sub get_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}"); + $msg = "on return: function_info[$i]{$role} = "; + $msg .= $function_info[$i]{$role}; + gp_message ("debugM", $subr_name, $msg); } } #------------------------------------------------------------------------------ @@ -8193,7 +8666,9 @@ sub get_function_info { for my $fields (sort keys %{ $function_address_and_index{$F} }) { - gp_message ("debug", $subr_name, "on return: function_address_and_index{$F}{$fields} = $function_address_and_index{$F}{$fields}"); + $msg = "on return: function_address_and_index{$F}{$fields} = "; + $msg .= $function_address_and_index{$F}{$fields}; + gp_message ("debugM", $subr_name, $msg); } } #------------------------------------------------------------------------------ @@ -8209,7 +8684,7 @@ sub get_function_info } #------------------------------------------------------------------------------ -# Print the data structure %function_view_structure. This is a hash. +# Print the data structure %function_view_structure. This is a hash. #------------------------------------------------------------------------------ for my $F (keys %function_view_structure) { @@ -8229,11 +8704,11 @@ sub get_function_info gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}"); if ($g_function_occurrences{$F} == 1) { - $number_of_unique_functions++; + $number_of_unique_functions++; } else { - $number_of_non_unique_functions++; + $number_of_non_unique_functions++; } } @@ -8246,25 +8721,23 @@ sub get_function_info #------------------------------------------------------------------------------ # TBD: Include in experiment data. Include names with multiple occurrences. #------------------------------------------------------------------------------ - my $msg; - $msg = "Number of source files : " . $num_source_files; gp_message ("debug", $subr_name, $msg); - $msg = "Total number of functions: $number_of_functions"; + $msg = "Total number of functions: $number_of_functions"; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions functions with a unique name : " . - $number_of_unique_functions; + $number_of_unique_functions; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions functions with more than one occurrence : " . - $number_of_non_unique_functions; + $number_of_non_unique_functions; gp_message ("debug", $subr_name, $msg); - my $multi_occurrences = $number_of_functions - $number_of_unique_functions; + my $multi_occurrences = $number_of_functions - $number_of_unique_functions; $msg = "Total number of multiple occurences of the same function name : " . - $multi_occurrences; + $multi_occurrences; gp_message ("debug", $subr_name, $msg); - return (\@function_info, \%function_address_and_index, \%addressobjtextm, + return (\@function_info, \%function_address_and_index, \%addressobjtextm, \%LINUX_vDSO, \%function_view_structure); } #-- End of subroutine get_function_info @@ -8302,7 +8775,7 @@ sub get_hdr_info { $ASORTFILE=$outputdir."calls"; $metric = "calls" - } + } elsif ($file eq $outputdir."calltree.sort.func") { $ASORTFILE=$outputdir."calltree"; @@ -8358,10 +8831,10 @@ sub get_hdr_info 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) @@ -8399,7 +8872,7 @@ sub get_hdr_info } #-- End of subroutine get_hdr_info #------------------------------------------------------------------------------ -# Get the home directory and the location(s) of the configuration file on the +# Get the home directory and the location(s) of the configuration file on the # current system. #------------------------------------------------------------------------------ sub get_home_dir_and_rc_path @@ -8416,22 +8889,22 @@ sub get_home_dir_and_rc_path $target_cmd = $g_mapped_cmds{"printenv"} . " HOME"; ($error_code, $home_dir) = execute_system_cmd ($target_cmd); - + if ($error_code != 0) { - my $msg = "cannot find a setting for HOME - please set this"; + my $msg = "cannot find a setting for HOME - please set this"; gp_message ("assertion", $subr_name, $msg); } else #------------------------------------------------------------------------------ -# The home directory is known and we can define the locations for the +# The home directory is known and we can define the locations for the # configuration file. #------------------------------------------------------------------------------ { @rc_file_paths = (".", "$home_dir"); - } - + } + gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths"); return ($home_dir, \@rc_file_paths); @@ -8487,7 +8960,7 @@ sub get_hot_functions #------------------------------------------------------------------------------ # Get the summary of the hot functions #------------------------------------------------------------------------------ - open (SCRIPT, ">", $script_file) + open (SCRIPT, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); @@ -8528,8 +9001,8 @@ sub get_hot_functions if ($error_code != 0) { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd"; @@ -8597,7 +9070,7 @@ sub get_index_function_info 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. #------------------------------------------------------------------------------ @@ -8625,9 +9098,9 @@ sub get_index_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 (); @@ -8635,14 +9108,14 @@ sub get_LANG_setting my $error_code; my $lang_setting; my $target_cmd; - my $command_string; + my $command_string; my $LANG; $target_cmd = $g_mapped_cmds{"printenv"}; #------------------------------------------------------------------------------ # Use the printenv command to get the settings for LANG. #------------------------------------------------------------------------------ - if ($target_cmd eq "road_to_nowhere") + if ($target_cmd eq "road to nowhere") { $error_code = 1; } @@ -8679,8 +9152,8 @@ sub get_metrics_data my @exp_dir_list = @{ $exp_dir_list_ref }; - my $cmd_options; - my $cmd_output; + my $cmd_options; + my $cmd_output; my $error_code; my $expr_name; my $metrics_cmd; @@ -8696,7 +9169,7 @@ sub get_metrics_data # to get all the output in files $outfile1 and $outfile2. These are then # parsed. #------------------------------------------------------------------------------ - $cmd_options = " -viewmode machine -compare off -thread_select all"; + $cmd_options = " -viewmode machine -compare off -thread_select all"; $cmd_options .= " -outfile $outfile2"; $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name"; @@ -8708,7 +9181,7 @@ sub get_metrics_data ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd); #------------------------------------------------------------------------------ -# Error handling. Any error that occurred is fatal and execution +# Error handling. Any error that occurred is fatal and execution # should be aborted by the caller. #------------------------------------------------------------------------------ if ($error_code == 0) @@ -8766,9 +9239,9 @@ sub get_my_name } #-- End of subroutine get_my_name -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Determine the characteristics of the current system -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub get_system_config_info { #------------------------------------------------------------------------------ @@ -8795,25 +9268,26 @@ sub get_system_config_info #------------------------------------------------------------------------------ my $subr_name = get_my_name (); - my $target_cmd; - my $hostname_current; my $error_code; - my $ignore_output; + my $hostname_current; + my $ignore_output; + my $msg; + my $target_cmd; #------------------------------------------------------------------------------ -# Test once if the command succeeds. This avoids we need to check every +# Test once if the command succeeds. This avoids we need to check every # specific # command below. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{uname}; ($error_code, $ignore_output) = execute_system_cmd ($target_cmd); - + if ($error_code != 0) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # This is unlikely to happen, but you never know. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { gp_message ("abort", $subr_name, "failure to execute the uname command"); } - + my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name); my $nodename = qx ($target_cmd -n); chomp ($nodename); my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release); @@ -8822,7 +9296,7 @@ sub get_system_config_info 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; @@ -8831,7 +9305,7 @@ sub get_system_config_info $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"); @@ -8841,7 +9315,7 @@ sub get_system_config_info 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. #------------------------------------------------------------------------------ @@ -8849,7 +9323,14 @@ sub get_system_config_info if (not $is_supported) { - gp_message ("error", $subr_name, "$machine is not supported"); + $msg = "the $machine instruction set architecture is not supported"; + gp_message ("error", $subr_name, $msg); + gp_message ("diag", $subr_name, "Error: " . $msg); + + $msg = "temporarily ignored for development purposes"; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; exit (0); } #------------------------------------------------------------------------------ @@ -8859,15 +9340,15 @@ sub get_system_config_info $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"); } @@ -8880,46 +9361,47 @@ sub get_system_config_info } #-- End of subroutine get_system_config_info -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # This subroutine prints a message. Several types of messages are supported. -# In case the type is "abort", or "error", execution is terminated. +# In case the type is "abort", or "error", execution is terminated. # -# Note that "debug", "warning", and "error" mode, the name of the calling -# subroutine is truncated to 30 characters. In case the name is longer, +# Note that "debug", "warning", and "error" mode, the name of the calling +# subroutine is truncated to 30 characters. In case the name is longer, # a warning message # is issued so you know this has happened. # -# Note that we use lcfirst () and ucfirst () to enforce whether the first +# Note that we use lcfirst () and ucfirst () to enforce whether the first # character is printed in lower or uppercase. It is nothing else than a # convenience, but creates more consistency across messages. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub gp_message { my $subr_name = get_my_name (); my ($action, $caller_name, $comment_line) = @_; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The debugXL identifier is special. It is accepted, but otherwise ignored. # This allows to (temporarily) disable debug print statements, but keep them # around. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my %supported_identifiers = ( - "verbose" => "[Verbose]", - "debug" => "[Debug]", - "error" => "[Error]", - "warning" => "[Warning]", - "abort" => "[Abort]", + "verbose" => "[Verbose]", + "debug" => "[Debug]", + "error" => "[Error]", + "warning" => "[Warning]", + "abort" => "[Abort]", "assertion" => "[Assertion error]", - "diag" => "", + "diag" => "", ); - my $debug_size; + my $debug_size; my $identifier; - my $fixed_size_name; + my $fixed_size_name; + my $ignore_value; my $string_limit = 30; my $strlen = length ($caller_name); my $trigger_debug = $FALSE; - my $truncated_name; + my $truncated_name; my $msg; if ($action =~ /debug\s*(.+)/) @@ -8933,11 +9415,11 @@ sub gp_message { 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; } } @@ -8953,9 +9435,9 @@ sub gp_message $trigger_debug = $TRUE; } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Catch any non-supported identifier. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if (defined ($supported_identifiers{$action})) { $identifier = $supported_identifiers{$action}; @@ -8964,113 +9446,168 @@ sub gp_message { die ("$subr_name - input error: $action is not supported"); } - if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off")) + if (($action eq "debug") and (not $g_debug)) { $trigger_debug = $FALSE; } -#------------------------------------------------------------------------------- -# Unconditionally buffer all warning messages. These are meant to be displayed -# separately. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Unconditionally buffer all warning messages. These are available through the +# index.html page and cannot be disabled. +# +# If the quiet mode has been enabled, warnings are not printed though. +#------------------------------------------------------------------------------ if ($action eq "warning") { - push (@g_warning_messages, ucfirst ($comment_line)); +#------------------------------------------------------------------------------ +# Remove any leading <br>, capitalize the first letter, and put the <br> back +# before storing the message in the buffer. +#------------------------------------------------------------------------------ + if ($comment_line =~ /^$g_html_new_line/) + { + $msg = $comment_line; + $msg =~ s/$g_html_new_line//; + $comment_line = $g_html_new_line . ucfirst ($msg); + + push (@g_warning_msgs, $comment_line); + } + else + { + push (@g_warning_msgs, ucfirst ($comment_line)); + } } -#------------------------------------------------------------------------------- -# Quick return in several cases. Note that "debug", "verbose", "warning", and +#------------------------------------------------------------------------------ +# Unconditionally buffer all errror messages. These will be printed prior to +# terminate execution. +#------------------------------------------------------------------------------ + if ($action eq "error") +#------------------------------------------------------------------------------ +# Remove any leading <br>, capitalize the first letter, and put the <br> back. +#------------------------------------------------------------------------------ + { + if ($comment_line =~ /^$g_html_new_line/) + { + $msg = $comment_line; + $msg =~ s/$g_html_new_line//; + $comment_line = $g_html_new_line . ucfirst ($msg); + + push (@g_error_msgs, $comment_line); + } + else + { + push (@g_error_msgs, ucfirst ($comment_line)); + } + } + +#------------------------------------------------------------------------------ +# Quick return in several cases. Note that "debug", "verbose", "warning", and # "diag" messages are suppressed in quiet mode, but "error", "abort" and # "assertion" always pass. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if (( ($action eq "verbose") and (not $g_verbose)) or (($action eq "debug") and (not $trigger_debug)) - or (($action eq "verbose") and ($g_quiet)) - or (($action eq "debug") and ($g_quiet)) - or (($action eq "warning") and (not $g_warnings)) + or (($action eq "verbose") and ($g_quiet)) + or (($action eq "debug") and ($g_quiet)) + or (($action eq "warning") and ($g_quiet)) or (($action eq "diag") and ($g_quiet))) { return (0); } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # In diag mode, just print the input line and nothing else. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if (( - $action eq "debug") + $action eq "debug") or ($action eq "abort") - or ($action eq "warning") - or ($action eq "assertion") - or ($action eq "error")) - { -#------------------------------------------------------------------------------- -# Construct the string to be printed. Include an identifier and the name of -# the function. -#------------------------------------------------------------------------------- + or ($action eq "assertion")) +## or ($action eq "error")) + { +#------------------------------------------------------------------------------ +# Construct the string to be printed. Include an identifier and the name of +# the function. +#------------------------------------------------------------------------------ if ($strlen > $string_limit) { $truncated_name = substr ($caller_name, 0, $string_limit); $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name); - print "Warning in $subr_name - the name of the caller is: $caller_name\n"; - print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n"; + print "Warning in $subr_name - the name of the caller is: " . + $caller_name . "\n"; + print "Warning in $subr_name - the string length is $strlen and " . + "exceeds $string_limit\n"; } else { $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name); } - if (($action eq "error") or ($action eq "abort")) -#------------------------------------------------------------------------------- +## if (($action eq "error") or ($action eq "abort")) + if ($action eq "abort") +#------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. Since these are # user errors, the name of the routine is not shown. The same for "abort". # If you want to display the routine name too, use an assertion. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - printf ("%-9s %s\n", $identifier, lcfirst ($comment_line)); + my $error_identifier = $supported_identifiers{"error"}; + if (@g_error_msgs) + { + $ignore_value = print_errors_buffer (\$error_identifier); + } + printf ("%-9s %s", $identifier, ucfirst ($comment_line)); + printf (" - %s\n", "execution is terminated"); } elsif ($action eq "assertion") -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); +#------------------------------------------------------------------------------ +# The lines are too long, but breaking the argument list gives this warning: +# printf (...) interpreted as function +#------------------------------------------------------------------------------ + printf ("%-17s %-30s", $identifier, $fixed_size_name); + printf (" - %s\n", $comment_line); } elsif (($action eq "debug") and ($trigger_debug)) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Debug messages are printed "as is". Avoids issues when searching for them ;-) -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); + printf ("%-9s %-30s", $identifier, $fixed_size_name); + printf (" - %s\n", $comment_line); } else -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { - printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line)); + printf ("%-9s %-30s", $identifier, $fixed_size_name); + printf (" - %s\n", $comment_line); } } elsif ($action eq "verbose") -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The first character in the verbose message is capatilized. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { printf ("%s\n", ucfirst ($comment_line)); } elsif ($action eq "diag") -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # The diag messages are meant to be diagnostics. Only the comment line is # printed. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ { printf ("%s\n", $comment_line); return (0); } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Terminate execution in case the identifier is "abort". -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ if (($action eq "abort") or ($action eq "assertion")) { ## print "ABORT temporarily disabled for testing purposes\n"; @@ -9080,91 +9617,91 @@ sub gp_message { return (0); } - + } #-- End of subroutine gp_message #------------------------------------------------------------------------------ -# Dynamically load the modules needed. Returns a list with the modules that -# could not be loaded. +# Create an HTML page with the warnings. If there are no warnings, include +# line to this extent. The alternative is to supporess the entire page, but +# that breaks the consistency in the output. #------------------------------------------------------------------------------ -sub handle_module_availability +sub html_create_warnings_page { my $subr_name = get_my_name (); - gp_message ("verbose", $subr_name, "Handling module requirements"); + my ($outputdir_ref) = @_; + + my $outputdir = ${ $outputdir_ref }; + + my $file_title; + my $html_acknowledgement; + my $html_end; + my $html_header; + my $html_home_left; + my $html_home_right; + my $html_title_header; + my $msg_no_warnings = "There are no warning messages issued."; + my $page_title; + my $position_text; + my $size_text; + + my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html"; + + gp_message ("debug", $subr_name, "outfile = $outfile"); + + open (WARNINGS_OUT, ">", $outfile) + or die ("unable to open $outfile for writing - '$!'"); + gp_message ("debug", $subr_name, "opened file $outfile for writing"); + + gp_message ("debug", $subr_name, "building warning file $outfile"); #------------------------------------------------------------------------------ -# This is clunky at best, but there is a chicken egg problem here. For the -# man page to be generated, the --help and --version options need to work, -# but this part of the code only works if the "stat" function is available. -# The "feature qw (state)" is required for the code to compile. -# -# TBD: Consider using global variables and to decouple parts of the option -# handling. -#; -## my @modules_used = ("feature", -## "File::stat", +# Generate some of the structures used in the HTML output. #------------------------------------------------------------------------------ - my @modules_used = ( - "List::Util", - "Cwd", - "File::Basename", - "File::stat", - "POSIX", - "bigint", - "bignum"); + $file_title = "Warning messages"; + $html_header = ${ create_html_header (\$file_title) }; + $html_home_right = ${ generate_home_link ("right") }; + + $page_title = "Warning Messages"; + $size_text = "h2"; + $position_text = "center"; + $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; - my @missing_modules = (); - my $cmd; - my $result; - #------------------------------------------------------------------------------ -# This loop checks for the availability of the modules and if so, imports -# the module. -# -# The names of missing modules, if any, are stored and printed in the error -# handling section below. +# Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------ - 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))"; - } - elsif ($m eq "bigint") - { - $cmd = $m . "->import ( qw (hex))"; - } - else - { - $cmd = $m . "->import"; - } - $cmd .= ";"; - $result = eval ("$cmd"); - gp_message ("debugM", $subr_name, "cmd = $cmd"); - } - else - { - push (@missing_modules, $m); - } - } + $html_home_left = ${ generate_home_link ("left") }; + $html_acknowledgement = ${ create_html_credits () }; + $html_end = ${ terminate_html_document () }; #------------------------------------------------------------------------------ -# Count the number of missing modules. It is upon the caller to decide what -# to do in case of errors. Currently, execution is aborted. +# Generate the HTML file. #------------------------------------------------------------------------------ - my $errors = scalar (@missing_modules); + print WARNINGS_OUT $html_header; + print WARNINGS_OUT $html_home_right; + print WARNINGS_OUT $html_title_header; - return (\$errors, \@missing_modules); + if ($g_total_warning_count > 0) + { + print WARNINGS_OUT "<pre>\n"; + print WARNINGS_OUT "$_\n" for @g_warning_msgs; + print WARNINGS_OUT "</pre>\n"; + } + else + { + print WARNINGS_OUT $msg_no_warnings; + } -} #-- End of subroutine handle_module_availability + print WARNINGS_OUT $html_home_left; + print WARNINGS_OUT "<br>\n"; + print WARNINGS_OUT $html_acknowledgement; + print WARNINGS_OUT $html_end; + + close (WARNINGS_OUT); + + return (0); + +} #-- End of subroutine html_create_warnings_page #------------------------------------------------------------------------------ # Generate the HTML with the experiment summary. @@ -9180,7 +9717,7 @@ sub html_generate_exp_summary my $file_title; my $outfile; my $page_title; - my $size_text; + my $size_text; my $position_text; my $html_header; my $html_home; @@ -9225,9 +9762,9 @@ sub html_generate_exp_summary ## 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 () }; @@ -9243,9 +9780,188 @@ sub html_generate_exp_summary } #-- End of subroutine html_generate_exp_summary -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Generate the index.html file. +#------------------------------------------------------------------------------ +sub html_generate_index +{ + my $subr_name = get_my_name (); + + my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, + $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, + $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, + $metric_description_reversed_ref, $table_execution_stats_ref) = @_; + + my $outputdir = ${ $outputdir_ref }; + my $html_first_metric_file = ${ $html_first_metric_file_ref }; + my $summary_metrics = ${ $summary_metrics_ref }; + my $number_of_metrics = ${ $number_of_metrics_ref }; + my @function_info = @{ $function_info_ref }; + my %function_address_info = %{ $function_address_info_ref }; + my @sort_fields = @{ $sort_fields_ref }; + my @exp_dir_list = @{ $exp_dir_list_ref }; + my %addressobjtextm = %{ $addressobjtextm_ref }; + my %metric_description_reversed = %{ $metric_description_reversed_ref }; + my @table_execution_stats = @{ $table_execution_stats_ref }; + + my @file_contents = (); + + my $acknowledgement; + my @abs_path_exp_dirs = (); + my $input_experiments; + my $target_function; + my $html_line; + my $ftag; + my $max_length = 0; + my %html_source_functions = (); + my $html_header; + my @experiment_directories = (); + my $html_acknowledgement; + my $html_file_title; + my $html_output_file; + my $html_function_view; + my $html_caller_callee_view; + my $html_experiment_info; + my $html_warnings_page; + my $href_link; + my $file_title; + my $html_gprofng; + my $html_end; + my $max_length_metrics; + my $page_title; + my $size_text; + my $position_text; + + my $ln; + my $base; + my $base_index_page; + my $infile; + my $outfile; + my $rec; + my $skip; + my $callsize; + my $dest; + my $final_string; + my @headers; + my $header; + my $sort_index; + my $pc_address; + my $anchor; + my $directory_name; + my $f2; + my $f3; + my $file; + my $sline; + my $src; + my $srcfile_name; + my $tmp1; + my $tmp2; + my $fullsize; + my $regf2; + my $trimsize; + my $EIL; + my $EEIL; + my $AOBJ; + my $RI; + my $HDR; + my $CALLER_CALLEE; + my $NAME; + my $SRC; + my $TRIMMED; + +#------------------------------------------------------------------------------ +# Add a forward slash to make it easier when creating file names. +#------------------------------------------------------------------------------ + $outputdir = append_forward_slash ($outputdir); + gp_message ("debug", $subr_name, "outputdir = $outputdir"); + + my $LANG = $g_locale_settings{"LANG"}; + my $decimal_separator = $g_locale_settings{"decimal_separator"}; + + $input_experiments = join (", ", @exp_dir_list); + + for my $i (0 .. $#exp_dir_list) + { + my $dir = get_basename ($exp_dir_list[$i]); + push @abs_path_exp_dirs, $dir; + } + $input_experiments = join (", ", @abs_path_exp_dirs); + + gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); + +#------------------------------------------------------------------------------ +# 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 (" . $g_total_warning_count; + $html_warnings_page .= ")</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 html_generate_index + +#------------------------------------------------------------------------------ # Generate the entries for the tables with the experiment info. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub html_generate_table_data { my $subr_name = get_my_name (); @@ -9256,15 +9972,15 @@ sub html_generate_table_data my @html_exp_table_data = (); my $html_line; ## my $html_header_line; - my $entry_name; + my $entry_name; my $key; - my $size_text; + my $size_text; my $position_text; - my $title_table_1; - my $title_table_2; - my $title_table_3; - my $title_table_summary; - my $html_table_title; + my $title_table_1; + my $title_table_2; + my $title_table_3; + my $title_table_summary; + my $html_table_title; my @experiment_table_1_def = (); my @experiment_table_2_def = (); @@ -9291,32 +10007,32 @@ sub html_generate_table_data $title_table_3 = "Run Time Statistics"; $title_table_summary = "Main Statistics"; - $size_text = "h3"; + $size_text = "h3"; $position_text = "left"; - push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"}; - push @experiment_table_1_def, { name => "Hostname" , key => "hostname"}; - push @experiment_table_1_def, { name => "Operating system", key => "OS"}; - push @experiment_table_1_def, { name => "Architecture", key => "architecture"}; - push @experiment_table_1_def, { name => "Page size", key => "page_size"}; - - push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"}; - push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"}; - push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"}; - push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"}; - - push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; -## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"}; - push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; -## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"}; - push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"}; -## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"}; - - push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"}; - push @exp_table_summary_def, { name => "Hostname" , key => "hostname"}; - push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; - push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; - push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"}; + push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"}; + push @experiment_table_1_def, { name => "Hostname" , key => "hostname"}; + push @experiment_table_1_def, { name => "Operating system", key => "OS"}; + push @experiment_table_1_def, { name => "Architecture", key => "architecture"}; + push @experiment_table_1_def, { name => "Page size", key => "page_size"}; + + push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"}; + push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"}; + push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"}; + push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"}; + + push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; +## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"}; + push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; +## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"}; + push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"}; +## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"}; + + push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"}; + push @exp_table_summary_def, { name => "Hostname" , key => "hostname"}; + push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; + push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; + push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"}; $html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) }; @@ -9363,13 +10079,13 @@ sub html_text_empty_file my ($comment_ref, $error_file_ref) = @_; - my $comment; - my $error_file; - my $error_message; - my $file_title; + my $comment; + my $error_file; + my $error_message; + my $file_title; my $html_end; my $html_header; - my $html_home; + my $html_home; my @html_empty_file = (); @@ -9410,9 +10126,10 @@ sub is_file_empty my ($filename) = @_; - my $size; - my $file_stat; my $is_empty; + my $file_stat; + my $msg; + my $size; chomp ($filename); @@ -9422,7 +10139,8 @@ sub is_file_empty # The return value is used in the caller. This is why we return the empty # string in case the file does not exist. #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "filename = $filename not found"); + $msg = "filename = $filename not found"; + gp_message ("debug", $subr_name, $msg); $is_empty = $TRUE; } else @@ -9432,7 +10150,8 @@ sub is_file_empty $is_empty = ($size == 0) ? $TRUE : $FALSE; } - gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty"); + $msg = "filename = $filename size = $size is_empty = $is_empty"; + gp_message ("debug", $subr_name, $msg); return ($is_empty); @@ -9451,7 +10170,7 @@ sub is_file_executable my $index_offset; my $is_executable; my $mode; - my $number_of_bytes; + my $number_of_bytes; my @permission_settings = (); my %permission_values = (); @@ -9477,7 +10196,7 @@ sub is_file_executable # Get username. We currently do not do anything with this though and the # code is commented out. # -# my $my_name = getlogin () || getpwuid($<) || "Kilroy";; +# my $my_name = getlogin () || getpwuid($<) || "Kilroy"; # gp_message ("debug", $subr_name, "my_name = $my_name"); #------------------------------------------------------------------------------ @@ -9524,7 +10243,7 @@ sub is_file_executable my $msg = "permission_values{" . $k . "} = " . $permission_values{$k}; gp_message ("debugXL", $subr_name, $msg); - + if ($permission_values{$k} % 2 == 0) { $is_executable = $FALSE; @@ -9539,9 +10258,32 @@ sub is_file_executable } #-- End of subroutine is_file_executable -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Print a message after a failure in $GP_DISPLAY_TEXT. +#------------------------------------------------------------------------------ +sub msg_display_text_failure +{ + my $subr_name = get_my_name (); + + my ($gp_display_text_cmd, $error_code, $error_file) = @_; + + my $msg; + + $msg = "error code = $error_code - failure executing the following command:"; + gp_message ("error", $subr_name, $msg); + + gp_message ("error", $subr_name, $gp_display_text_cmd); + + $msg = "check file $error_file for more details"; + gp_message ("error", $subr_name, $msg); + + return (0); + +} #-- End of subroutine msg_display_text_failure + +#------------------------------------------------------------------------------ # TBD. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub name_regex { my $subr_name = get_my_name (); @@ -9578,12 +10320,12 @@ sub name_regex gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-"); -#------------------------------------------------------------------------------- -# According to https://perldoc.perl.org/File::Basename, both dirname and +#------------------------------------------------------------------------------ +# According to https://perldoc.perl.org/File::Basename, both dirname and # basename are not reliable and fileparse () is recommended instead. # # Note that $gp_metrics_dir has a trailing "/". -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC"); gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file"); @@ -9614,10 +10356,10 @@ sub name_regex $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; @@ -9632,9 +10374,9 @@ sub name_regex if ($is_calls or $is_calltree) { -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Remove any inclusive metrics from the list. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/) { $pre = $1; @@ -9652,15 +10394,15 @@ sub name_regex 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; @@ -9672,11 +10414,11 @@ sub name_regex } } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # 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) { @@ -9712,8 +10454,8 @@ sub name_regex { my $a; my $am; - $a = $m; - $a =~ s/^a/e/; + $a = $m; + $a =~ s/^a/e/; $am = ${ retrieve_metric_description (\$a, \%metric_description) }; $am =~ s/Exclusive/Attributed/; push (@moo,"$m:$am\n"); @@ -9759,7 +10501,7 @@ sub name_regex if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree")) { $mf = $nf + 1; - } + } else { for my $candidate_metric (@splitted_metrics) @@ -9777,8 +10519,8 @@ sub name_regex if ($mf == 1) { $re = "^\\s*(\\S+)"; # metric value - } - else + } + else { $re = "^\\s*\\S+"; } @@ -9792,8 +10534,8 @@ sub name_regex if ($m == $mf) { $re .= "\\s+(\\S+)"; # metric value - } - else + } + else { $re .= "\\s+\\S+"; } @@ -9809,8 +10551,8 @@ sub name_regex { $re .= "\\s+.*\\+-(.*)"; # name $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?) - } - else + } + else { $re .= "\\s+(.*)"; # name $Xre .= "\\s+(.*)\$"; # name @@ -9828,9 +10570,9 @@ sub name_regex } #-- End of subroutine name_regex -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # TBD -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub nosrc { my $subr_name = get_my_name (); @@ -9862,7 +10604,7 @@ sub nosrc #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ -sub numerically +sub numerically { my $f1; my $f2; @@ -9875,8 +10617,8 @@ sub numerically $f2 = int ($2); $f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1); } - } - else + } + else { return ($a <=> $b); } @@ -9884,307 +10626,406 @@ sub 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. +# some more specific to the option, plus cross option checks, will be +# performed soon after this subroutine has executed. +# +# Warnings, but also errors, are buffered. In this way we can collect as many +# warnings and errors as possible, before bailing out in case of an error. #------------------------------------------------------------------------------ sub parse_and_check_user_options { my $subr_name = get_my_name (); - my ($no_of_args_ref, $option_list_ref) = @_; - - my $no_of_args = ${ $no_of_args_ref }; - my @option_list = @{ $option_list_ref }; - my @exp_dir_list; my $arg; - my $calltree_value; - my $debug_value; - my $default_metrics_value; - my $func_limit_value; + my $calltree_value; + my $debug_value; + my $default_metrics_value; + my $func_limit_value; my $found_exp_dir = $FALSE; - my $ignore_metrics_value; + my $ignore_metrics_value; my $ignore_value; - my $message; + my $msg; my $outputdir_value; - my $quiet_value; + my $quiet_value; my $hp_value; my $valid; - my $verbose_value; + my $verbose_value; + + my $number_of_fields; + + my $internal_option_name; + my $option_name; + + my $verbose = undef; + my $warning = undef; + + my @opt_debug = (); + my @opt_highlight_percentage = (); + my @opt_nowarnings = (); + my @opt_obsoleted_hp = (); + my @opt_output = (); + my @opt_overwrite = (); + my @opt_quiet = (); + my @opt_verbose = (); + my @opt_warnings = (); - $no_of_args++; +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ + my $no_of_warnings; + my $total_warning_msgs = 0; + my $option_value; + my $option_warnings; + my $no_of_warnings_ref; + my $no_of_errors_ref; + + my $index_exp; + my $first = $TRUE; + my $trigger = $FALSE; + my $found_non_exp = $FALSE; + my $name_non_exp_dir; + my $no_of_experiments = 0; + + my @opt_help = (); + my @opt_version = (); + my $stop_execution = $FALSE; + + my $option_value_ref; + my $max_occurrences; +#------------------------------------------------------------------------------ +# Configure Getopt to: +# - Silence warnings, since these are handled by the code. +# - Enforce case sensitivity in order to support -o and -O for example. +#------------------------------------------------------------------------------ + Getopt::Long::Configure("pass_through", "no_ignore_case"); - gp_message ("debug", $subr_name, "no_of_args = $no_of_args"); - gp_message ("debug", $subr_name, "option_list = @option_list"); +#------------------------------------------------------------------------------ +# Check for the --help and --version options. Print a message and exit. +# Note that we support using both options simultaneously on the command line. +#------------------------------------------------------------------------------ + GetOptions ( + "help" => \@opt_help, + "version" => \@opt_version + ); - my $option_errors = 0; + if (@opt_help) + { + $stop_execution = $TRUE; + $ignore_value = print_help_info (); + } + if (@opt_version) + { + $stop_execution = $TRUE; + $ignore_value = print_version_info (); + } - while (defined ($arg = shift @ARGV)) + if ($stop_execution) { - gp_message ("debug", $subr_name, "parsing options arg = $arg"); - gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV"); + exit (0); + } #------------------------------------------------------------------------------ -# The gprofng driver adds this option. We need to get rid of it. +# First, scan ARGV for the experiment names. If there are no names, or the +# list with the names is not contiguous (meaning there is an non-experiment +# name in this list), an error message is printed and execution is terminated. +# +# Upon return from this function, the list with the experiment names is +# known and has been removed from ARGV. +# +# As a result, exp_dir_list is available from there on. +# +# This makes the subsequent processing of ARGV with GetOptions() easier. #------------------------------------------------------------------------------ - next if ($arg eq "--whoami=gprofng display html"); + @exp_dir_list = @{ check_the_experiment_list () }; #------------------------------------------------------------------------------ -# Parse the input options and check for the values to be valid. +# Configure Getopt to: +# - Silence warnings, since these are handled by the code. +# - Enforce case sensitivity in order to support -o and -O for example. +# - Allow unique abbreviations (also the default). +#------------------------------------------------------------------------------ + Getopt::Long::Configure("pass_through", "no_ignore_case", "auto_abbrev"); +#------------------------------------------------------------------------------ +# Get the remaining command line options. # -# Valid values are stored in the main option table. +# Recall: +# = => option requires a value +# : => option value is optional +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# All options are considered to be a string. # -# TBD: The early check handles some of these already and the duplicates -# can be removed. Be aware of some global settings though. +# We request every option supported to have an optional value. Otherwise, +# GetOptions skips an option that does not have a value. +# +# The logic that parses the options deals with this and checks if an option +# that should have a value, actually has one. #------------------------------------------------------------------------------ - if ($arg eq "--version") - { - print_version_info (); - exit (0); - } - elsif ($arg eq "--help") + GetOptions ( + "verbose|v:s" => \@opt_verbose, + "debug|d:s" => \@opt_debug, + "warnings|w:s" => \@opt_warnings, + "nowarnings:s" => \@opt_nowarnings, + "quiet|q:s" => \@opt_quiet, + "output|o=s" => \@opt_output, + "overwrite|O=s" => \@opt_overwrite, + "highlight-percentage=s" => \@opt_highlight_percentage, + "hp=s" => \@opt_obsoleted_hp + ); + +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ +# Handle the user input and where needed, generate warnings. In a later stage +# we check for (cross option) errors and warnings. +#------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# The very first thing to do is to determine if the user has enabled one of the +# following options and take action accordingly: +# --quiet, --verbose, --debug, --warnings +# +# We first need to check for quiet mode to be set. If so, all messages need to +# be silenced, regardless of the settings for verbose, debug, and warnings. +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# The quiet option. +#------------------------------------------------------------------------------ + if (@opt_quiet) + { + $max_occurrences = 1; + $internal_option_name = "quiet"; + $option_name = "--quiet"; + + my ($valid_ref) = extract_option_value (\@opt_quiet, + \$max_occurrences, + \$internal_option_name, + \$option_name); + + $valid = ${ $valid_ref }; + + if ($valid) { - $ignore_value = print_help_info (); - exit (0); + $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? + $TRUE : $FALSE; } - elsif (($arg eq "-v") or ($arg eq "--verbose")) + } + +#------------------------------------------------------------------------------ +# The debug option. +#------------------------------------------------------------------------------ + if (@opt_debug) + { + $max_occurrences = 1; + $internal_option_name = "debug"; + $option_name = "-d/--debug"; + + my ($valid_ref) = extract_option_value (\@opt_debug, + \$max_occurrences, + \$internal_option_name, + \$option_name); + + $valid = ${ $valid_ref }; + + if ($valid) +#------------------------------------------------------------------------------ +# Set the appropriate debug size (e.g. "XL") in a table that is used in the +# gp_message() subroutine. +#------------------------------------------------------------------------------ { - $verbose_value = shift @ARGV; - $valid = check_user_option ("verbose", $verbose_value); - if (not $valid) - { - $option_errors++; - } - else - { - $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; - } - next; + $g_debug = $TRUE; + $ignore_value = set_debug_size (); } - elsif (($arg eq "-w") or ($arg eq "--warnings")) + } + +#------------------------------------------------------------------------------ +# The verbose option. +#------------------------------------------------------------------------------ + if (@opt_verbose) + { + $max_occurrences = 1; + $internal_option_name = "verbose"; + $option_name = "--verbose"; + + my ($valid_ref) = extract_option_value (\@opt_verbose, + \$max_occurrences, + \$internal_option_name, + \$option_name); + $valid = ${ $valid_ref }; + + if ($valid) { - my $warnings_value = shift @ARGV; - $valid = check_user_option ("warnings", $warnings_value); - if (not $valid) - { - $option_errors++; - } - else - { - $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; - } - next; + $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? + $TRUE : $FALSE; } - elsif (($arg eq "-d") or ($arg eq "--debug")) - { - $debug_value = shift @ARGV; - $valid = check_user_option ("debug", $debug_value); - if (not $valid) - { - $option_errors++; - } - else - { + } + #------------------------------------------------------------------------------ -# This function internally converts the value to uppercase. +# The nowarnings option. #------------------------------------------------------------------------------ - my $ignore_value = set_debug_size (\$debug_value); - } - next; - } - elsif (($arg eq "-q") or ($arg eq "--quiet")) - { - $quiet_value = shift @ARGV; - $valid = check_user_option ("quiet", $quiet_value); + if (@opt_nowarnings) + { + $max_occurrences = 1; + $internal_option_name = "nowarnings"; + $option_name = "--nowarnings"; - if (not $valid) - { - $option_errors++; - } - else - { - $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; - } - next; - } - elsif (($arg eq "-o") or ($arg eq "--output")) - { - $outputdir_value = shift @ARGV; - $valid = check_user_option ("output", $outputdir_value); + my ($valid_ref) = extract_option_value (\@opt_nowarnings, + \$max_occurrences, + \$internal_option_name, + \$option_name); - if (not $valid) - { - $option_errors++; - } + $valid = ${ $valid_ref }; - next; - } - elsif (($arg eq "-O") or ($arg eq "--overwrite")) + if ($valid) { - $outputdir_value = shift @ARGV; - $valid = check_user_option ("overwrite", $outputdir_value); + $g_warnings = + $g_user_settings{"nowarnings"}{"current_value"} eq "on" ? + $FALSE : $TRUE; + } + } - if (not $valid) - { - $option_errors++; - } +#------------------------------------------------------------------------------ +# The warnings option (deprecated). +#------------------------------------------------------------------------------ + if (@opt_warnings) + { + $max_occurrences = 1; + $internal_option_name = "warnings"; + $option_name = "--warnings"; - next; - } - elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage")) - { - $hp_value = shift @ARGV; - $valid = check_user_option ("highlight_percentage", $hp_value); + my ($valid_ref) = extract_option_value (\@opt_warnings, + \$max_occurrences, + \$internal_option_name, + \$option_name); + } - if (not $valid) - { - $option_errors++; - } +#------------------------------------------------------------------------------ +# At this point, the debug, verbose, warnings and quiet settings are known. +# This subroutine makes the final decision on these settings. For example, if +# quiet mode has been specified, the settings for debug, verbose and warnings +# are ignored. +#------------------------------------------------------------------------------ + $ignore_value = finalize_special_options (); - next; - } -# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) -# Temporarily disabled { -# Temporarily disabled $func_limit_value = shift @ARGV; -# Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value); -# Temporarily disabled -# Temporarily disabled if (not $valid) -# Temporarily disabled { -# Temporarily disabled $option_errors++; -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled next; -# Temporarily disabled } -# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) -# Temporarily disabled { -# Temporarily disabled $calltree_value = shift @ARGV; -# Temporarily disabled $valid = check_user_option ("calltree", $calltree_value); -# Temporarily disabled -# Temporarily disabled if (not $valid) -# Temporarily disabled { -# Temporarily disabled $option_errors++; -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled next; -# Temporarily disabled } -# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) -# Temporarily disabled { -# Temporarily disabled $tp_value = shift @ARGV; -# Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value); -# Temporarily disabled -# Temporarily disabled if (not $valid) -# Temporarily disabled { -# Temporarily disabled $option_errors++; -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled next; -# Temporarily disabled } -# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) -# Temporarily disabled { -# Temporarily disabled $default_metrics_value = shift @ARGV; -# Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value); -# Temporarily disabled -# Temporarily disabled if (not $valid) -# Temporarily disabled { -# Temporarily disabled $option_errors++; -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled next; -# Temporarily disabled } -# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) -# Temporarily disabled { -# Temporarily disabled $ignore_metrics_value = shift @ARGV; -# Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value); -# Temporarily disabled -# Temporarily disabled if (not $valid) -# Temporarily disabled { -# Temporarily disabled $option_errors++; -# Temporarily disabled } -# Temporarily disabled -# Temporarily disabled next; -# Temporarily disabled } - else - { - #------------------------------------------------------------------------------ -# When we get to this part of the code it means that the current command line -# argument is not a known option. -# -# We check if it is the name of an experiment directory and if so, add it to -# the list with directories to use. -# -# If not, print an error message and increment the error variable because this -# is clearly something that is not right. -#------------------------------------------------------------------------------- +# A this point we know we can start printing messages in case verbose and/or +# debug mode have been set. +#------------------------------------------------------------------------------ + $msg = "the original command line options: " . join (", ", @CopyOfARGV); + gp_message ("debug", $subr_name, $msg); - if ($arg =~ /^\-.*/) - { -#------------------------------------------------------------------------------- -# It is an option, but not a supported one. Print a message and increment -# the error count. -#------------------------------------------------------------------------------- - $message = "option $arg is not a known option"; - push (@g_user_input_errors, $message); + $msg = "the command line options after the special options: " . + join (", ", @ARGV); + gp_message ("debug", $subr_name, $msg); - $option_errors++; - } - else - { -#------------------------------------------------------------------------------- -# Other than options, the input has to consist of at least one directory name. -# First remove any trailing slashes (/) and then check if the name is valid. -#------------------------------------------------------------------------------- - $arg =~ s/\/*\/$//; - if ($arg =~ /.+\.er$/) - { -#------------------------------------------------------------------------------- -# It is the name of an experiment directory and is added to the list. -#------------------------------------------------------------------------------- - $found_exp_dir = $TRUE; - push (@exp_dir_list, $arg); - } - else - { -#------------------------------------------------------------------------------- -# It is not a valid experiment directory name. Print a message and exit. -#------------------------------------------------------------------------------- - $message = "not a valid experiment directory name: $arg"; - push (@g_user_input_errors, $message); + gp_message ("verbose", $subr_name, "Parsing the user options"); - $option_errors++; - } - } +#------------------------------------------------------------------------------ +# The output option. +#------------------------------------------------------------------------------ + if (@opt_output) + { + $max_occurrences = 1; + $internal_option_name = "output"; + $option_name = "-o/--output"; - } #-- End of last else + my ($valid_ref) = extract_option_value (\@opt_output, + \$max_occurrences, + \$internal_option_name, + \$option_name); + } - } #-- End of while-loop +#------------------------------------------------------------------------------ +# The overwrite option. +#------------------------------------------------------------------------------ + if (@opt_overwrite) + { + $max_occurrences = 1; + $internal_option_name = "overwrite"; + $option_name = "-O/--overwrite"; + + my ($valid_ref) = extract_option_value (\@opt_overwrite, + \$max_occurrences, + \$internal_option_name, + \$option_name); + } -#------------------------------------------------------------------------------- -# Check if the name of the experiment directories is valid. Note that later -# we check for these directories to exist. -#------------------------------------------------------------------------------- - if (not $found_exp_dir) +#------------------------------------------------------------------------------ +# The highlight-percentage option. +#------------------------------------------------------------------------------ + if (@opt_highlight_percentage) { - $message = "experiment directory name(s) are either not valid, or missing"; - push (@g_user_input_errors, $message); + $max_occurrences = 1; + $internal_option_name = "highlight_percentage"; + $option_name = "--highlight-percentage"; - $option_errors++; + my ($valid_ref) = extract_option_value (\@opt_highlight_percentage, + \$max_occurrences, + \$internal_option_name, + \$option_name); } #------------------------------------------------------------------------------ -# Check for fatal errors to have occurred. If so, stop execution. Otherwise, -# confirm the verbose setting. +# The hp option (deprecated) +#------------------------------------------------------------------------------ + if (@opt_obsoleted_hp) + { + $max_occurrences = 1; + $internal_option_name = "hp"; + $option_name = "-hp"; + + my ($valid_ref) = extract_option_value (\@opt_obsoleted_hp, + \$max_occurrences, + \$internal_option_name, + \$option_name); + } + +#------------------------------------------------------------------------------ +# By now, all options given on the command line have been processed and the +# list with experiment directories is known. +# +# Process the remainder of ARGV, but other than the option generated by the +# driver, ARGV should be empty. +#------------------------------------------------------------------------------ + $ignore_value = wrap_up_user_options (); + +# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) +# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) +# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) +# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) +# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) + + if (@exp_dir_list) +#------------------------------------------------------------------------------ +# Print the list of the experiment directories found. +# +# Note that later we also check for these directories to actually exist +# and be valid experiments.. #------------------------------------------------------------------------------ - if ($option_errors > 0) { - gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found"); + $found_exp_dir = $TRUE; + $msg = "the following experiment directories will be used:"; + gp_message ("debug", $subr_name, $msg); + for my $i (keys @exp_dir_list) + { + my $msg = "exp_dir_list[$i] = $exp_dir_list[$i]"; + gp_message ("debug", $subr_name, $msg); + } } else +#------------------------------------------------------------------------------ +# Print a message if the experiment list is not valid, or empty. There will +# also be error messages in the buffer. These will be printed later. +#------------------------------------------------------------------------------ { - gp_message ("debug", $subr_name, "no errors in the options found"); + $msg = "experiment directory name(s) are either not valid, or missing"; + gp_message ("debug", $subr_name, $msg); } - return ($option_errors, $found_exp_dir, \@exp_dir_list); + return (\$found_exp_dir, \@exp_dir_list); } #-- End of subroutine parse_and_check_user_options @@ -10195,12 +11036,12 @@ sub parse_dis_files { my $subr_name = get_my_name (); - my ($number_of_metrics_ref, $function_info_ref, - $function_address_and_index_ref, $input_string_ref, + my ($number_of_metrics_ref, $function_info_ref, + $function_address_and_index_ref, $input_string_ref, $addressobj_index_ref) = @_; #------------------------------------------------------------------------------ -# Note that $function_address_and_index_ref is not used, but we need to pass +# Note that $function_address_and_index_ref is not used, but we need to pass # in the address into generate_dis_html. #------------------------------------------------------------------------------ my $number_of_metrics = ${ $number_of_metrics_ref }; @@ -10214,16 +11055,17 @@ sub parse_dis_files my $dis_filename_id_regex = 'file\.([0-9]+)\.dis'; my $filename; + my $msg; my $outputdir = append_forward_slash ($input_string); my @source_line = (); - my $source_line_ref; + my $source_line_ref; my @metric = (); my $metric_ref; my $target_function; - + gp_message ("debug", $subr_name, "building disassembly files"); gp_message ("debug", $subr_name, "outputdir = $outputdir"); @@ -10258,24 +11100,38 @@ sub parse_dis_files gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id"); } } - + $filename = $_; gp_message ("verbose", $subr_name, " Processing disassembly file $filename"); ($source_line_ref, $metric_ref) = generate_dis_html ( \$target_function, - \$number_of_metrics, - $function_info_ref, - $function_address_and_index_ref, - \$outputdir, - \$filename, - \@source_line, - \@metric, + \$number_of_metrics, + $function_info_ref, + $function_address_and_index_ref, + \$outputdir, + \$filename, + \@source_line, + \@metric, \%addressobj_index); @source_line = @{ $source_line_ref }; - @metric = @{ $metric_ref }; + +#------------------------------------------------------------------------------ +# TBD. This part needs work. The return variables from generate_dis_html () +# are not used, so the code below is meaningless, but awaiting a true fix, +# the problem which appears on aarch64 is bypassed. +#------------------------------------------------------------------------------ + if (defined ($metric_ref)) + { + @metric = @{ $metric_ref }; + } + else + { + $msg = "metric_ref after generate_dis_html is undefined"; + gp_message ("debug", $subr_name, $msg); + } } - + return (0) } #-- End of subroutine parse_dis_files @@ -10303,9 +11159,9 @@ sub parse_source_files gp_message ("debug", $subr_name, "processing source file: $_"); my $found_target = process_source ( - $number_of_metrics, - $function_info_ref, - $outputdir_with_slash, + $number_of_metrics, + $function_info_ref, + $outputdir_with_slash, $_); if (not $found_target) @@ -10327,16 +11183,16 @@ sub prepend_backslashes gp_message ("debug", $subr_name, "target_string on entry = $target_string"); - $target_string =~ s/\(/\\\(/g; - $target_string =~ s/\)/\\\)/g; - $target_string =~ s/\+/\\\+/g; - $target_string =~ s/\[/\\\[/g; - $target_string =~ s/\]/\\\]/g; - $target_string =~ s/\*/\\\*/g; - $target_string =~ s/\./\\\./g; - $target_string =~ s/\$/\\\$/g; - $target_string =~ s/\^/\\\^/g; - $target_string =~ s/\#/\\\#/g; + $target_string =~ s/\(/\\\(/g; + $target_string =~ s/\)/\\\)/g; + $target_string =~ s/\+/\\\+/g; + $target_string =~ s/\[/\\\[/g; + $target_string =~ s/\]/\\\]/g; + $target_string =~ s/\*/\\\*/g; + $target_string =~ s/\./\\\./g; + $target_string =~ s/\$/\\\$/g; + $target_string =~ s/\^/\\\^/g; + $target_string =~ s/\#/\\\#/g; gp_message ("debug", $subr_name, "target_string on return = $target_string"); @@ -10355,8 +11211,8 @@ sub preprocess_function_files my $outputdir = append_forward_slash ($input_string); my @sort_fields = @{ $sort_fields_ref }; - - my $error_code; + + my $error_code; my $cmd_output; my $re; @@ -10409,103 +11265,280 @@ sub preprocess_function_files } #-- End of subroutine preprocess_function_files -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Print the original list with the command line options. +#------------------------------------------------------------------------------ +sub print_command_line_options +{ + my ($identifier_ref) = @_; + + my $identifier = ${ $identifier_ref }; + my $msg; + + $msg = "The command line options (shown for ease of reference): "; + printf ("%-9s %s\n", $identifier, ucfirst ($msg)); + + $msg = join (", ", @CopyOfARGV); + printf ("%-9s %s\n", $identifier, $msg); + +# printf ("%-9s\n", $identifier); + + return (0); + +} #-- End of subroutine print_command_line_options + +#------------------------------------------------------------------------------ +# Print all the errors messages in the buffer. +#------------------------------------------------------------------------------ +sub print_errors_buffer +{ + my $subr_name = get_my_name (); + + my ($identifier_ref) = @_; + + my $ignore_value; + my $msg; + my $plural_or_single; + my $identifier = ${ $identifier_ref }; + + $plural_or_single = ($g_total_error_count > 1) ? "errors have" : "error has"; + + if (@g_warning_msgs and $g_warnings) +#------------------------------------------------------------------------------ +# Make sure that all warnings are printed in case of an error. This is to +# avoid that warnings get lost in case the program terminates early. +#------------------------------------------------------------------------------ + { + $ignore_value = print_warnings_buffer (); + } + + if (not $g_options_printed) +#------------------------------------------------------------------------------ +# The options are printed as part of the warnings, so only if the warnings are +# not printed, we need to print them in case of errors. +#------------------------------------------------------------------------------ + { + $g_options_printed = $TRUE; + $ignore_value = print_command_line_options (\$identifier); + } + + $msg = "a total of " . $g_total_error_count; + $msg .= " fatal " . $plural_or_single . " been detected:"; + printf ("%-9s %s\n", $identifier, ucfirst ($msg)); + + for my $key (keys @g_error_msgs) + { + $msg = $g_error_msgs[$key]; + printf ("%-11s %s\n", $identifier, ucfirst ($msg)); + } + + return (0); + +} #-- End of subroutine print_errors_buffer + +#------------------------------------------------------------------------------ # Print the help overview -#------------------------------------------------------------------------------- -sub print_help_info +#------------------------------------------------------------------------------ +sub print_help_info { - print - #-------Marker line - do not go beyond this line ------------------------------ - "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n". - "\n". - "Process one or more experiments to generate a directory containing the\n" . - "index.html file that may be used to browse the experiment data.\n". - "\n". - "Options:\n". - "\n". - " --help print usage information and exit.\n". - " --version print the version number and exit.\n". - " --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" . - " messages about the processing of the data; default\n" . - " is off.\n". - #-------Marker line - do not go beyond this line ------------------------------ - " -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" . - " to assist with troubleshooting, or further\n" . - " development of this tool; on gives a modest amount\n" . - " of information; s, m, l, or xl gives an increasing\n" . - " amount of information and off disables the printing\n" . - " of debug information; note that currently on, s, m,\n" . - " and l are equivalent; this is expected to change in\n" . - " future updates; default is off.\n" . - #-------Marker line - do not go beyond this line ------------------------------ - " -hp, ----highlight-percentage <value> a percentage value in the interval\n" . - " [0,100] to select and color code source\n" . - " lines as well as instructions that are\n" . - " within this percentage of the maximum\n" . - " metric value(s); a value of zero (-hp 0)\n" . - " disables this feature; the default is 90.\n". - #-------Marker line - do not go beyond this line ------------------------------ - " -o, --output <dir-name> use <dir-name> to store the results in; the\n" . - " default name is ./display.<n>.html with <n> the\n" . - " first positive integer number not in use; an\n" . - " existing directory is not overwritten.\n". - #-------Marker line - do not go beyond this line ------------------------------ - " -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" . - " overwrite any existing directory with the\n" . - " same name; make sure that umask is set to the\n" . - " correct access permissions.\n" . - #-------Marker line - do not go beyond this line ------------------------------ - " -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" . - " verbose messages; if set to on, the settings for\n" . - " verbose, warnings and debug are ignored; default\n" . - " is off.\n". - #-------Marker line - do not go beyond this line ------------------------------ - " -w, --warnings {on|off} enable/disable run time warning messages;\n" . - " default is on.\n". - "\n". -# Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n". -# Temmporarily disabled " this is an integer number; set to 0 to process all\n". -# Temmporarily disabled " functions; the default value is 100.\n". -# Temmporarily disabled "\n". -# Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n". -# Temmporarily disabled " from the bottom of the first page; default is off.\n". -# Temmporarily disabled "\n". -# Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n". -# Temmporarily disabled " inclusion of functions for each metric will take\n". -# Temmporarily disabled " place in sort order until the percentage has been\n". -# Temmporarily disabled " reached.\n". -# Temmporarily disabled "\n". -# Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n". -# Temmporarily disabled " and use a default set of metrics; the default is off.\n". -# Temmporarily disabled "\n". -# Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n". -# Temmporarily disabled "\n". -# Temmporarily disabled "Environment:\n". -# Temmporarily disabled "\n". -# Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n". -# Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n". -# Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n". -# Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n". -# Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n". -# Temmporarily disabled "\n". - "Documentation:\n". - "\n". - "A getting started guide for gprofng is maintained as a Texinfo manual.\n" . - "If the info and gprofng programs are properly installed at your site,\n" . - "the command \"info gprofng\" should give you access to this document.\n". - "\n". - "See also:\n". - "\n". - "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " . - "gp-display-text(1)\n"; - - return (0); + my $space = " "; + + printf("%s\n", + "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)"); + printf("\n"); + printf("%s\n", + "Process one or more experiments to generate a directory containing the"); + printf("%s\n", + "index.html file that may be used to browse the experiment data."); + printf("\n"); + printf("%s\n", + "Options:"); + printf("\n"); + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("--help", + "Print usage information and exit."); + + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("--version", + "Print the version number and exit."); + + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("--verbose", + "Enable verbose mode to show diagnostic messages about the"); + print_help_line ("", + "processing of the data. By default verbose mode is disabled."); + + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("-d [<db-vol-size>], --debug[=<db-vol-size>]", + "Control the printing of run time debug information to assist with"); + print_help_line ("", + "the troubleshooting, or further development of this tool."); + print_help_line ("", + "The <db-vol-size> parameter controls the output volume and is"); + print_help_line ("", + "one from the list {s | S | m | M | l | L | xl | XL}."); + print_help_line ("", + "If db-vol-size is not specified, a modest amount of information"); + print_help_line ("", + "is printed. This is equivalent to select size s, or S. The"); + print_help_line ("", + "volume of data goes up as the size increases. Note that"); + print_help_line ("", + "currently l/L is equivalent to xl/XL, but this is expected to"); + print_help_line ("", + "change in future updates. By default debug mode is disabled."); + + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("--highlight-percentage=<value>", + "A percentage value in the interval [0,100] to select and color"); + print_help_line ("", + "code source lines, as well as instructions, that are within this"); + print_help_line ("", + "percentage of the maximum metric value(s). A value of zero"); + print_help_line ("", + "disables this feature. The default value is 90 (%)."); + + #-------Marker line - do not go beyond this line ---------------------------- + print_help_line ("-o <dirname>, --output=<dirname>", + "Use <dirname> as the directory name to store the results in."); + print_help_line ("", + "In absence of this option, the default name is display.<n>.html."); + print_help_line ("", + "This directory is created in the current directory. The number"); + print_help_line ("", + "<n> is the first positive integer number not in use in this"); + print_help_line ("", + "naming scheme. An existing directory with the same name is not"); + print_help_line ("", + "overwritten. Make sure that umask is set to the correct access"); + print_help_line ("", + "permissions."); + + #-------Marker line - do not go beyond this line -------------------------- + print_help_line ("-O <dirname>, --overwrite=<dirname>", + "Use <dirname> as the directory name to store the results in."); + print_help_line ("", + "In absence of this option, the default name is display.<n>.html."); + print_help_line ("", + "This directory is created in the current directory. The number"); + print_help_line ("", + "<n> is the first positive integer number not in use in this"); + print_help_line ("", + "naming scheme. An existing directory with the same name is"); + print_help_line ("", + "silently overwritten. Make sure that umask is set to the"); + print_help_line ("", + "correct access permissions."); + + #-------Marker line - do not go beyond this line -------------------------- + print_help_line ("-q, --quiet", + "Disable the display of all warning, debug, verbose and any"); + print_help_line ("", + "other messages. If enabled, the settings for verbose and debug"); + print_help_line ("", + "are accepted, but ignored. With this option, there is no screen"); + print_help_line ("", + "output, other than errors. By default quiet mode is disabled"); + + #-------Marker line - do not go beyond this line -------------------------- + print_help_line ("--nowarnings", + "Disable the printing of warning messages on stdout. By default"); + print_help_line ("", + "warning messages are printed."); + + #-------Marker line - do not go beyond this line -------------------------- + printf("\n"); + printf ("%s\n","Report bugs to <https://sourceware.org/bugzilla/>"); + + return (0); } #-- End of subroutine print_help_info -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ +# Print a single line as part of the help output. +# +# If the first item is not the empty string, it is considered to be the +# option. If the length of the option exceeds the limit set by $max_space, +# it is printed by itself and the text is printed on the next line. Otherwise +# the text follows the option. +# +# To assist with the development of the help text, we check if the total length +# of the line exceeds the max numbers of columns (79 according to the GNU +# coding standards). +#------------------------------------------------------------------------------ +sub print_help_line +{ + my $subr_name = get_my_name (); + + my ($item, $help_text) = @_; + + my $length_item = length ($item); + my $max_col = 79; + my $max_space = 14; + my $no_of_spaces; + my $pad; + my $space = " "; + my $the_message; + + if ($length_item > $max_col) + { + printf ("Error: $item is $length_item long - exceeds $max_col\n"); + exit (0); + } + elsif ( $length_item == 0 ) + { + $no_of_spaces = $max_space; + + $pad = ""; + for my $i (1..$no_of_spaces) + { + $pad .= $space; + } + $the_message = $pad . $help_text; + } + else + { + if ($length_item < $max_space) + { + $no_of_spaces = $max_space - length ($item); + $pad = ""; + for my $i (1..$no_of_spaces) + { + $pad .= $space; + } + $the_message = $item . $pad . $help_text; + } + else + { + $pad = ""; + for my $i (1..$max_space) + { + $pad .= $space; + } + printf("%s\n", $item); + $the_message = $pad . $help_text; + } + } + + if (length ($the_message) <= $max_col) + { + printf ("%s\n", $the_message); + } + else + { + my $delta = length ($the_message) - $max_col; + printf ("%s\n", "$the_message - exceeds $max_col by $delta"); + exit (0); + } + + + return (0); + +} #-- End of subroutine print_help_line + +#------------------------------------------------------------------------------ # Print the meta data for each experiment directory. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub print_meta_data_experiments { my $subr_name = get_my_name (); @@ -10526,7 +11559,7 @@ sub 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, +# level information. This version is for a top level array structure, # followed by a hash. #------------------------------------------------------------------------------ sub print_metric_function_array @@ -10535,7 +11568,7 @@ sub print_metric_function_array my ($metric, $struct_type_name, $target_structure_ref) = @_; - my @target_structure = @{$target_structure_ref}; + my @target_structure = @{$target_structure_ref}; gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); @@ -10564,7 +11597,7 @@ sub print_metric_function_hash my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_; - my %target_structure = %{$target_structure_ref}; + my %target_structure = %{$target_structure_ref}; gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); @@ -10595,7 +11628,7 @@ sub print_metric_function_hash gp_message ("assertion", $subr_name, $msg); } } - + return (0); } #-- End of subroutine print_metric_function_hash @@ -10624,7 +11657,7 @@ sub print_opening_message #------------------------------------------------------------------------------ # If there are at least two entries, find the last comma and replace it by -# " and". Note that we know there is at least one comma, so the value +# " and". Note that we know there is at least one comma, so the value # returned by rindex () cannot be -1. #------------------------------------------------------------------------------ if ($no_of_dirs > 1) @@ -10646,7 +11679,7 @@ sub print_opening_message } $msg .= ($time_percentage_multiplier*100.0)."% of the time"; - + gp_message ("verbose", $subr_name, $msg); } #-- End of subroutine print_opening_message @@ -10691,14 +11724,14 @@ sub print_program_header # In case the length of the comment exceeds the length of the dashed line, # the comment line is allowed to stick out to the right. # -# If the length of the comment is less than the dashed line, it is centered -# relative to the # length of the dashed line. +# If the length of the comment is less than the dashed line, it is centered +# relative to the # length of the dashed line. -# If the length of the comment and this line do not divide, an extra space is +# If the length of the comment and this line do not divide, an extra space is # added to the left of the comment. # # For example, if the comment is 55 long, there are 5 spaces to be distributed. -# There will be 3 spaces, followed by the comment. +# There will be 3 spaces, followed by the comment. #------------------------------------------------------------------------------ sub print_table_user_settings { @@ -10706,17 +11739,19 @@ sub print_table_user_settings my ($mode, $comment) = @_; + my $data_type; + my $debug_size_value = $g_user_settings{"debug"}{"current_value"}; + my $db_size; + my $defined; + my $keyword; my $leftover; my $padding; - - my $keyword; my $user_option; - my $defined; my $value; - my $data_type; - my $HEADER_LIMIT = 60; - my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value"); + my $HEADER_LIMIT = 79; + my $header = sprintf ("%-20s %-22s %8s %s", + "keyword", "option", "user set", "internal value"); #------------------------------------------------------------------------------ # Generate the dashed line @@ -10742,7 +11777,7 @@ sub print_table_user_settings { $padding = 0; } - + #------------------------------------------------------------------------------ # Generate the first blank part of the line. #------------------------------------------------------------------------------ @@ -10766,34 +11801,44 @@ sub print_table_user_settings #------------------------------------------------------------------------------ # Print a line for each option. The list is sorted alphabetically. #------------------------------------------------------------------------------ - for my $rc_keyword (sort keys %g_user_settings) + for my $key (sort keys %g_user_settings) { - $keyword = $rc_keyword; - $user_option = $g_user_settings{$rc_keyword}{"option"}; - $defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set"); - $data_type = $g_user_settings{$rc_keyword}{"data_type"}; + $keyword = $key; + $user_option = $g_user_settings{$key}{"option"}; + $defined = ($g_user_settings{$key}{"defined"} ? "set" : "not set"); + $data_type = $g_user_settings{$key}{"data_type"}; - if (defined ($g_user_settings{$rc_keyword}{"current_value"})) + if (defined ($g_user_settings{$key}{"current_value"})) { - $value = $g_user_settings{$rc_keyword}{"current_value"}; + $value = $g_user_settings{$key}{"current_value"}; if ($data_type eq "boolean") { $value = $value ? "on" : "off"; } +#------------------------------------------------------------------------------ +# In case of the debug option, we add the "(size)" string to remind the user +# that this is the size. +#------------------------------------------------------------------------------ + if ($key eq "debug") + { + $db_size = ($debug_size_value eq "on") ? "s" : $debug_size_value; + $value = $db_size . " (size)"; + } } else { - $value = "undefined"; + $value = "undefined"; } - my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value); + my $print_line = sprintf ("%-20s %-22s %8s %s", + $keyword, $user_option, $defined, $value); gp_message ($mode, $subr_name, $print_line); } } #-- End of subroutine print_table_user_settings #------------------------------------------------------------------------------ -# Dump the contents of nested hash "g_user_settings". Some simple formatting +# Dump the contents of nested hash "g_user_settings". Some simple formatting # is applied to make it easier to distinguish the various values. #------------------------------------------------------------------------------ sub print_user_settings @@ -10802,18 +11847,18 @@ sub print_user_settings my ($mode, $comment) = @_; - my $keyword_value_pair; + my $keyword_value_pair; gp_message ($mode, $subr_name, $comment); - for my $rc_keyword (keys %g_user_settings) + for my $key (keys %g_user_settings) { - my $print_line = sprintf ("%-20s =>", $rc_keyword); - for my $fields (sort keys %{ $g_user_settings{$rc_keyword} }) + my $print_line = sprintf ("%-20s =>", $key); + for my $fields (sort keys %{ $g_user_settings{$key} }) { - if (defined ($g_user_settings{$rc_keyword}{$fields})) + if (defined ($g_user_settings{$key}{$fields})) { - $keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields}; + $keyword_value_pair = $fields." = ".$g_user_settings{$key}{$fields}; } else { @@ -10828,7 +11873,7 @@ sub print_user_settings #------------------------------------------------------------------------------ # Print the version number and license information. #------------------------------------------------------------------------------ -sub print_version_info +sub print_version_info { print "$version_info\n"; print "Copyright (C) 2023 Free Software Foundation, Inc.\n"; @@ -10841,13 +11886,47 @@ sub print_version_info } #-- End of subroutine print_version_info #------------------------------------------------------------------------------ +# Dump all the warning messages in the buffer. +#------------------------------------------------------------------------------ +sub print_warnings_buffer +{ + my $subr_name = get_my_name (); + + my $ignore_value; + my $msg; + + if (not $g_options_printed) +#------------------------------------------------------------------------------ +# Only if the options have not yet been printed, print them. +#------------------------------------------------------------------------------ + { + $g_options_printed = $TRUE; + $ignore_value = print_command_line_options (\$g_warn_keyword); + } + + for my $i (keys @g_warning_msgs) + { + $msg = $g_warning_msgs[$i]; + if ($msg =~ /^$g_html_new_line/) + { + $msg =~ s/$g_html_new_line//; + printf ("%-9s\n", $g_warn_keyword); + } + printf ("%-9s %s\n", $g_warn_keyword, ucfirst ($msg)); + } + + return (0); + +} #-- End of subroutine print_warnings_buffer + +#------------------------------------------------------------------------------ # Process the call tree input data and generate HTML output. #------------------------------------------------------------------------------ sub process_calltree { my $subr_name = get_my_name (); - my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, + my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, $input_string) = @_; my @function_info = @{ $function_info_ref }; @@ -10864,16 +11943,16 @@ sub process_calltree my $infile = $outputdir . "calltree"; my $outfile = $outputdir . "calltree.html"; - open (CALL_TREE_IN, "<", $infile) + open (CALL_TREE_IN, "<", $infile) or die ("Not able to open calltree file $infile for reading - '$!'"); gp_message ("debug", $subr_name, "opened file $infile for reading"); - open (CALL_TREE_OUT, ">", $outfile) + open (CALL_TREE_OUT, ">", $outfile) or die ("Not able to open $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); gp_message ("debug", $subr_name, "building calltree file $outfile"); - + #------------------------------------------------------------------------------ # The directory name is potentially used below, but since it is a constant, # we get it here and only once. @@ -10892,13 +11971,13 @@ sub process_calltree my $size_text = "h2"; my $position_text = "center"; my $html_title_header = ${ generate_a_header ( - \$page_title, - \$size_text, + \$page_title, + \$size_text, \$position_text) }; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Get the acknowledgement, return to main link, and final html statements. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ my $html_home_left = ${ generate_home_link ("left") }; my $html_acknowledgement = ${ create_html_credits () }; my $html_end = ${ terminate_html_document () }; @@ -10922,17 +12001,17 @@ sub process_calltree 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; @@ -10944,9 +12023,9 @@ sub process_calltree } #-- End of subroutine process_calltree -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Process the generated experiment info file(s). -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub process_experiment_info { my $subr_name = get_my_name (); @@ -10976,9 +12055,9 @@ sub process_experiment_info 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+\'(.+)\''; @@ -11015,9 +12094,9 @@ sub process_experiment_info 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"}; @@ -11027,15 +12106,15 @@ sub process_experiment_info my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file"; gp_message ("debug", $subr_name, $msg); - open (EXPERIMENT_INFO, "<", $exp_data_file) + open (EXPERIMENT_INFO, "<", $exp_data_file) or die ("$subr_name - unable to open file $exp_data_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $exp_data_file for reading"); chomp (@exp_info = <EXPERIMENT_INFO>); -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Process the info for the current experiment. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ for my $line (0 .. $#exp_info) { $input_line = $exp_info[$line]; @@ -11067,13 +12146,13 @@ sub process_experiment_info gp_message ("debugM", $subr_name, "$exp_id => $start_date"); $experiment_data[$i]{"start_date"} = $start_date; } - elsif ($input_line =~ /$end_experiment_regex/) + elsif ($input_line =~ /$end_experiment_regex/) { $end_experiment = $1; gp_message ("debugM", $subr_name, "$exp_id => $end_experiment"); $experiment_data[$i]{"end_experiment"} = $end_experiment; } - elsif ($input_line =~ /$data_collection_duration_regex/) + elsif ($input_line =~ /$data_collection_duration_regex/) { $data_collection_duration = $1; gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration"); @@ -11087,7 +12166,7 @@ sub process_experiment_info # 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%) @@ -11100,13 +12179,13 @@ sub process_experiment_info # Wait CPU: 0. ( 0. %) # Sleep: 0.056 ( 3.1%) #------------------------------------------------------------------------------ - elsif ($input_line =~ /$total_thread_time_regex/) + elsif ($input_line =~ /$total_thread_time_regex/) { $total_thread_time = $1; gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time"); $experiment_data[$i]{"total_thread_time"} = $total_thread_time; } - elsif ($input_line =~ /$user_cpu_regex/) + elsif ($input_line =~ /$user_cpu_regex/) { $user_cpu_time = $1; $user_cpu_percentage = $2; @@ -11114,7 +12193,7 @@ sub process_experiment_info $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")"; $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage; } - elsif ($input_line =~ /$system_cpu_regex/) + elsif ($input_line =~ /$system_cpu_regex/) { $system_cpu_time = $1; $system_cpu_percentage = $2; @@ -11122,7 +12201,7 @@ sub process_experiment_info $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")"; $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage; } - elsif ($input_line =~ /$sleep_regex/) + elsif ($input_line =~ /$sleep_regex/) { $sleep_time = $1; $sleep_percentage = $2; @@ -11157,14 +12236,14 @@ 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, + my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier, + $summary_metrics, $process_all_functions, $elf_loadobjects_found, + $outputdir, $sort_fields_ref, $function_info_ref, + $function_address_and_index_ref, $LINUX_vDSO_ref, + $metric_description_ref, $elf_arch, $base_va_executable, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; - my $old_fsummary; + my $old_fsummary; my $total_attributed_time; my $current_attributed_time; my $value; @@ -11216,7 +12295,7 @@ sub process_function_files my $srcfile; my $RIN; my $gp_listings_cmd; - my $gp_display_text_cmd; + my $gp_display_text_cmd; my $ignore_value; my $result_file = $outputdir . "gp-listings.out"; @@ -11246,30 +12325,30 @@ sub process_function_files gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-"); - + # Function_info creates the functions files from the PC ones # as well as culling PC and metric information - ($function_address_info_ref, - $functions_per_metric_first_index_ref, + ($function_address_info_ref, + $functions_per_metric_first_index_ref, $functions_per_metric_indexes_ref) = function_info ( - $outputdir, - $infile, - $metric, + $outputdir, + $infile, + $metric, $LINUX_vDSO_ref); @{$function_address_info{$metric}} = @{$function_address_info_ref}; %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref}; %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref}; - $ignore_value = print_metric_function_array ($metric, - "function_address_info", + $ignore_value = print_metric_function_array ($metric, + "function_address_info", \@{$function_address_info{$metric}}); - $ignore_value = print_metric_function_hash ("hash_hash", $metric, - "functions_per_metric_first_index", + $ignore_value = print_metric_function_hash ("hash_hash", $metric, + "functions_per_metric_first_index", \%{$functions_per_metric_first_index{$metric}}); - $ignore_value = print_metric_function_hash ("hash_array", $metric, - "functions_per_metric_indexes", + $ignore_value = print_metric_function_hash ("hash_array", $metric, + "functions_per_metric_indexes", \%{$functions_per_metric_indexes{$metric}}); } @@ -11297,7 +12376,7 @@ sub process_function_files { get_hdr_info ($outputdir, $outputdir."calltree.sort.func"); } - + gp_message ("debug", $subr_name, "process functions"); my $scriptfile = $outputdir.'gp-script'; @@ -11318,21 +12397,21 @@ sub process_function_files for my $metric (@sort_fields) { gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}"); - + $total_attributed_time = 0; $current_attributed_time = 0; - + $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total> if ($convert_to_dot) { $value =~ s/$decimal_separator/\./; } $total_attributed_time = $value; - + #------------------------------------------------------------------------------ # start at 1 - skipping <Total> #------------------------------------------------------------------------------ - for my $INDEX (1 .. $#{$function_address_info{$metric}}) + for my $INDEX (1 .. $#{$function_address_info{$metric}}) { #------------------------------------------------------------------------------ #Looking to handle at least 99% of the time - or what the user asked for @@ -11343,14 +12422,14 @@ sub process_function_files gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time"); gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)"); - if ($convert_to_dot) + if ($convert_to_dot) { $value =~ s/$decimal_separator/\./; } if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or - ( ($total_attributed_time == 0) and ($value>0) ) or - $process_all_functions) + ( ($total_attributed_time == 0) and ($value>0) ) or + $process_all_functions) { $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"}; @@ -11363,22 +12442,22 @@ sub process_function_files gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}"); } - if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and + if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and exists ($function_address_and_index{$routine}{$PCA})) { #------------------------------------------------------------------------------ # handled_routines now contains $RI from "first_metric" (?) #------------------------------------------------------------------------------ - $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; + $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; if ($metric_description{$metric} =~ /Exclusive Total CPU Time/) { - $routine_list{$routine} = 1 + $routine_list{$routine} = 1 } gp_message ("debugXL", $subr_name, " $routine is candidate"); - } - else + } + else { die ("internal error for metric $metric and routine $routine"); } @@ -11401,13 +12480,13 @@ sub process_function_files $function_info[$routine_index]{"srcline"} = ""; $address_field = $function_info[$routine_index]{"addressobjtext"}; -## $disfile = "file\.$routine_index\.dis"; +## $disfile = "file\.$routine_index\.dis"; $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"}; $srcfile = ""; $srcfile = "file\.$routine_index\.src.txt"; #------------------------------------------------------------------------------ -# If the file is unknown, we can disassemble anyway and add disassembly +# If the file is unknown, we can disassemble anyway and add disassembly # to the script. #------------------------------------------------------------------------------ print SCRIPT "# outfile $outputdir"."$disfile\n"; @@ -11452,14 +12531,14 @@ sub process_function_files $limit_txt = $func_limit - 1; } - $number_of_metrics = scalar (@sort_fields); + $number_of_metrics = scalar (@sort_fields); $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics"; gp_message ("debugXL", $subr_name, "built function list with $RIN functions"); gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt"); -# add ELF program header offset +# add ELF program header offset for my $routine_index (sort {$a <=> $b} keys %handled_routines) { @@ -11490,9 +12569,9 @@ sub process_function_files $function_info[$routine_index]{"addressobj"} += bigint::hex ( determine_base_va_address ( - $executable_name, - $base_va_executable, - $loadobj, + $executable_name, + $base_va_executable, + $loadobj, $routine)); $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index; @@ -11517,10 +12596,10 @@ sub process_function_files if ($error_code != 0) { - $ignore_value = msg_display_text_failure ($gp_display_text_cmd, - $error_code, + $ignore_value = msg_display_text_failure ($gp_display_text_cmd, + $error_code, $gp_error_file); - gp_message ("abort", "execution terminated"); + gp_message ("abort", $subr_name, "execution terminated"); } return (\@function_info, \%function_address_info, \%addressobj_index); @@ -11534,7 +12613,7 @@ sub process_function_files # # 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 @@ -11557,29 +12636,29 @@ sub process_function_overview my %function_view_structure = %{ $function_view_structure_ref }; my $overview_file = ${ $overview_file_ref }; - my $all_metrics; + my $all_metrics; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $length_of_block; - my $elements_in_name; + my $elements_in_name; my $full_hex_address; my $header_line; my $hex_address; my $html_line; my $input_line; - my $name_regex; - my $no_of_fields; + my $name_regex; + my $no_of_fields; my $metrics_length; - my $missing_digits; + my $missing_digits; my $remaining_part_header; - my $routine; - my $routine_length; + my $routine; + my $routine_length; my $scan_header = $FALSE; my $scan_function_data = $FALSE; my $string_length; - my $total_header_lines; + my $total_header_lines; my @address_field = (); - my @fields = (); + my @fields = (); my @function_data = (); my @function_names = (); my @function_view_array = (); @@ -11603,10 +12682,10 @@ sub process_function_overview #------------------------------------------------------------------------------ if (is_file_empty ($overview_file)) { - gp_message ("error", $subr_name, "assertion error: file $overview_file is empty"); + gp_message ("assertion", $subr_name, "file $overview_file is empty"); } - open (FUNC_OVERVIEW, "<", $overview_file) + open (FUNC_OVERVIEW, "<", $overview_file) or die ("$subr_name - unable to open file $overview_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $overview_file for reading"); @@ -11627,9 +12706,9 @@ sub process_function_overview 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; @@ -11653,7 +12732,7 @@ sub process_function_overview { $scan_header = $TRUE; } - elsif ($input_line =~ /$total_marker_regex/) + elsif ($input_line =~ /$total_marker_regex/) { $scan_header = $FALSE; $scan_function_data = $TRUE; @@ -11662,7 +12741,7 @@ sub process_function_overview if ($scan_header) { #------------------------------------------------------------------------------ -# This group is only defined for the first line of the header and $4 contains +# This group is only defined for the first line of the header and $4 contains # the remaining part of the line after "Name", without the leading spaces. #------------------------------------------------------------------------------ if (defined ($4)) @@ -11672,7 +12751,7 @@ sub process_function_overview gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ -# Determine the maximum length of the header. This needs to be done before +# Determine the maximum length of the header. This needs to be done before # the HTML controls are added. #------------------------------------------------------------------------------ my $header_length = length ($remaining_part_header); @@ -11692,7 +12771,7 @@ sub process_function_overview # 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"); @@ -11708,7 +12787,7 @@ sub process_function_overview 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. @@ -11721,17 +12800,17 @@ sub process_function_overview $elements_in_name = $no_of_fields - $number_of_metrics - 1; gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name"); - + #------------------------------------------------------------------------------ # TBD: Handle this better in case a function entry has more than 2 words. # Build the regex dynamically and use eval to capture the correct group. # CHECK CODE IN GENERATE_CALLER_CALLEE #------------------------------------------------------------------------------ - if ($elements_in_name == 1) + if ($elements_in_name == 1) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)'; } - elsif ($elements_in_name == 2) + elsif ($elements_in_name == 2) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)'; } @@ -11745,20 +12824,20 @@ sub process_function_overview $full_hex_address = $1; $routine = $2; - if ($elements_in_name == 1) + if ($elements_in_name == 1) { $all_metrics = $3; } - elsif ($elements_in_name == 2) + elsif ($elements_in_name == 2) { $all_metrics = $5; } #------------------------------------------------------------------------------ -# In case the last metric is 0. only, we append 3 extra characters that +# In case the last metric is 0. only, we append 3 extra characters that # represent zero. We cannot change the number to 0.000 though because that # has a different interpretation than 0. -# In a later phase, the "ZZZ" symbol will be removed again, but for now it +# In a later phase, the "ZZZ" symbol will be removed again, but for now it # creates consistency in, for example, the length of the metrics part. #------------------------------------------------------------------------------ if ($all_metrics =~ /$zero_dot_at_end_regex/) @@ -11771,7 +12850,7 @@ sub process_function_overview #------------------------------------------------------------------------------ my $decimal_point = $decimal_separator; $decimal_point =~ s/$backward_slash_regex//; - my $txt = "all_metrics = $all_metrics ended with 0"; + my $txt = "all_metrics = $all_metrics ended with 0"; $txt .= "$decimal_point ($decimal_separator)"; gp_message ("debugXL", $subr_name, $txt); @@ -11780,14 +12859,14 @@ sub process_function_overview } $metrics_length = length ($all_metrics); $max_metrics_length = max ($max_metrics_length, $metrics_length); - gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); + gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); if ($full_hex_address =~ /$get_hex_address_regex/) { $hex_address = "0x" . $2; } - push (@address_field, $hex_address); + push (@address_field, $hex_address); push (@metric_values, $all_metrics); #------------------------------------------------------------------------------ @@ -11817,7 +12896,7 @@ sub process_function_overview my @function_index_list = (); #------------------------------------------------------------------------------ -# First, an index list is built. If we are to index the functions in order of +# First, an index list is built. If we are to index the functions in order of # appearance in the function overview from 0 to n-1, the value of the array # for index "i" is the index into the large "function_info" structure. This # has the final name, the html function block, etc. @@ -11836,8 +12915,8 @@ sub process_function_overview my $current_address = $address_field[$i]; my $found_a_match = $FALSE; - my $final_function_name; - my $ref_index; + my $final_function_name; + my $ref_index; #------------------------------------------------------------------------------ # Check if there are duplicate entries for this function. If there are, use @@ -11856,7 +12935,7 @@ sub process_function_overview # 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"); @@ -11882,7 +12961,7 @@ sub process_function_overview if (defined ($g_map_function_to_index{$routine}[0])) { $found_a_match = $TRUE; - $ref_index = $g_map_function_to_index{$routine}[0]; + $ref_index = $g_map_function_to_index{$routine}[0]; push (@function_index_list, $ref_index); my $final_function_name = $function_info[$ref_index]{"routine"}; gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name"); @@ -11900,7 +12979,7 @@ sub process_function_overview } #------------------------------------------------------------------------------ -# The loop over all function names has completed and @function_index_list +# The loop over all function names has completed and @function_index_list # contains the index values into @function_info for the functions. # # All we now need to do is to retrieve the correct field(s) from the array. @@ -11972,17 +13051,17 @@ sub process_function_overview # be there. # # TBD: Check if this can be done only once. -# ------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ my $target_keyword = "Excl."; ($foundit_ref, $index_values_ref) = find_keyword_in_string ( - \$remaining_part_header, + \$remaining_part_header, \$target_keyword); $foundit = ${ $foundit_ref }; @index_values = @{ $index_values_ref }; - if ($foundit) + if ($foundit) { for my $i (keys @index_values) { @@ -11996,7 +13075,7 @@ sub process_function_overview gp_message ("assertion", $subr_name, $msg); } -# ------------------------------------------------------------------------------ +#------------------------------------------------------------------------------ # Compute the number of spaces we need to add between the "(sort)" strings. # # For example: @@ -12012,11 +13091,11 @@ sub process_function_overview # 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) @@ -12035,7 +13114,7 @@ sub process_function_overview 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. @@ -12062,19 +13141,19 @@ sub process_function_overview # The current metric should have a different background color. #------------------------------------------------------------------------------ { - $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . - "." . $metric_value . ".html' style='background-color:" . - $g_html_color_scheme{"background_selected_sort"} . + $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . + "." . $metric_value . ".html' style='background-color:" . + $g_html_color_scheme{"background_selected_sort"} . "\'><b>(sort)</b></a>"; } elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric)) #------------------------------------------------------------------------------ -# Set the background color for the sort metric in the main function overview. +# Set the background color for the sort metric in the main function overview. #------------------------------------------------------------------------------ { - $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . - "." . $metric_value . ".html' style='background-color:" . - $g_html_color_scheme{"background_selected_sort"} . + $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . + "." . $metric_value . ".html' style='background-color:" . + $g_html_color_scheme{"background_selected_sort"} . "'><b>(sort)</b></a>"; } else @@ -12082,7 +13161,7 @@ sub process_function_overview # Do not set a specific background for all other metrics. #------------------------------------------------------------------------------ { - $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . + $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . "." . $metric_value . ".html'>(sort)</a>"; } @@ -12124,7 +13203,7 @@ sub process_function_overview gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ -# Element "function table" contains the array with all the function view data. +# Element "function table" contains the array with all the function view data. #------------------------------------------------------------------------------ $function_view_structure{"header"} = [@header_lines]; $function_view_structure{"metrics part"} = [@metrics_part]; @@ -12156,13 +13235,13 @@ sub process_metrics my ($html_metrics_record,$imetric,$metric); $html_metrics_record = - "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . + "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n"; $outfile = $outputdir . "metrics.html"; - open (METRICSOUT, ">", $outfile) + open (METRICSOUT, ">", $outfile) or die ("$subr_name - unable to open file $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); @@ -12194,7 +13273,7 @@ sub process_metrics # $imetricn = scalar (keys %IMETRICS); $imetricn = scalar (keys %ignored_metrics); - if ($imetricn) + if ($imetricn) { $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">"; # for $imetric (sort keys %IMETRICS){ @@ -12216,9 +13295,9 @@ sub process_metrics } #-- End of subroutine process_metrics -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # TBD -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ sub process_metrics_data { my $subr_name = get_my_name (); @@ -12240,7 +13319,7 @@ sub process_metrics_data my $metric_name; my $metric_text; my $metricdata; - my $metric_line; + my $metric_line; my $summary_metrics; my $detail_metrics; @@ -12262,12 +13341,12 @@ sub process_metrics_data my ($last_metric,$metric,$value,$i,$r); - open (METRICTOTALS, "<", $outfile2) + open (METRICTOTALS, "<", $outfile2) or die ("Unable to open metric value data file $outfile2 for reading - '$!'"); gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data"); #------------------------------------------------------------------------------ -# Below an example of the file that has just been opened. The lines I marked +# Below an example of the file that has just been opened. The lines I marked # with a * has been wrapped by my for readability. This is not the case in the # file, but makes for a really long line. # @@ -12284,9 +13363,9 @@ sub process_metrics_data # Inclusive Instructions Executed: 54417033412 (100.0%) # Exclusive Last-Level Cache Misses: 252730685 (100.0%) # Inclusive Last-Level Cache Misses: 252730685 (100.0%) -# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: -# * Exclusive Cycles Per Instruction: -# * Inclusive Cycles Per Instruction: +# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: +# * Exclusive Cycles Per Instruction: +# * Inclusive Cycles Per Instruction: # * Size: 0 # PC Address: 1:0x00000000 # Source File: (unknown) @@ -12302,7 +13381,7 @@ sub process_metrics_data gp_message ("debug", $subr_name, "file metrictotals: $metricdata"); #------------------------------------------------------------------------------ -# Ignoring whitespace, search for any line with a ":" in it, followed by +# Ignoring whitespace, search for any line with a ":" in it, followed by # a number with or without a dot. So, an integer or floating-point number. #------------------------------------------------------------------------------ if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/) @@ -12376,7 +13455,7 @@ sub process_metrics_data if (scalar (keys %metric_value) == 0) #------------------------------------------------------------------------------ -# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we +# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we # blow up later. # # TBD: See if this can be handled differently. @@ -12437,7 +13516,7 @@ sub process_metrics_data # 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/)) # @@ -12451,7 +13530,7 @@ sub process_metrics_data #------------------------------------------------------------------------------ # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ - ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = + ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = extract_metric_specifics ($metric_line); # if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) @@ -12498,17 +13577,17 @@ sub process_metrics_data { $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. #------------------------------------------------------------------------------ @@ -12530,13 +13609,13 @@ sub process_metrics_data gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1"); $detail_metrics_system = $detail_metrics_system.':'.$metric_spec; gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1"); - } + } else { gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); } - } - else + } + else { $summary_metrics = $metric_spec; gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2"); @@ -12546,19 +13625,19 @@ sub process_metrics_data gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2"); $detail_metrics_system = $metric_spec; gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2"); - } - else + } + else { gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); } } gp_message ("debug", $subr_name, " metric $metric_spec added"); - } - else + } + else { gp_message ("debug", $subr_name, "m: no want above metric was a 0 total"); } - } + } } } @@ -12596,7 +13675,7 @@ sub process_metrics_data { $summary_metrics = "e.user:".$summary_metrics; } - else + else { $summary_metrics = "e.user:i.user:".$summary_metrics; } @@ -12610,8 +13689,8 @@ sub process_metrics_data if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) { $call_metrics = "a.user:".$call_metrics; - } - else + } + else { $call_metrics = "a.user:i.user:".$call_metrics; } @@ -12650,7 +13729,7 @@ sub process_non_target_source { my $subr_name = get_my_name (); - my ($start_scan, $end_scan, + my ($start_scan, $end_scan, $src_times_regex, $function_regex, $number_of_metrics, $file_contents_ref, $modified_html_ref) = @_; @@ -12672,9 +13751,9 @@ sub process_non_target_source # Generate straightforward HTML, but define an anchor based on the source line # number in the list. #------------------------------------------------------------------------------ - $line_id = extract_source_line_number ($src_times_regex, - $function_regex, - $number_of_metrics, + $line_id = extract_source_line_number ($src_times_regex, + $function_regex, + $number_of_metrics, $input_line); if ($input_line =~ /$function_regex/) @@ -12692,13 +13771,13 @@ sub process_non_target_source #------------------------------------------------------------------------------ $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; - my $coloured_line; + my $coloured_line; if ($colour_code_line) { my $boldface = $TRUE; $coloured_line = color_string ( - $input_line, - $boldface, + $input_line, + $boldface, $g_html_color_scheme{"non_target_function_name"}); $colour_code_line = $FALSE; $modified_line .= "$coloured_line"; @@ -12721,6 +13800,9 @@ sub process_non_target_source # # Errors are stored during the parsing and processing phase. They are printed # at the end and sorted by line number. +# +# +# TBD: Does not yet use the warnings/error system. This needs to be fixed. #------------------------------------------------------------------------------ sub process_rc_file { @@ -12731,19 +13813,21 @@ sub process_rc_file #------------------------------------------------------------------------------ # Local structures. #------------------------------------------------------------------------------ - my %rc_settings_user = (); #-- Store the values extracted from the config file +# Stores the values extracted from the config file: + my %rc_settings_user = (); my %error_and_warning_msgs = (); - my @rc_file_paths = (); + my @rc_file_paths = (); my @split_line; my @my_fields; - my $message; - my $first_part; + my $msg; + my $first_part; my $line; my $line_number; - my $number_of_fields; - my $number_of_paths; + my $no_of_arguments; + my $number_of_fields; + my $number_of_paths; my $parse_errors; #-- Count the number of errors my $parse_warnings; #-- Count the number of errors @@ -12767,16 +13851,19 @@ sub process_rc_file #------------------------------------------------------------------------------ # Check for the presence of a configuration file. #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"); + $msg = "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"; + gp_message ("debug", $subr_name, $msg); $rc_file_found = $FALSE; for my $path_name (@rc_file_paths) { $rc_config_file = $path_name . "/" . $rc_file_name; - gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file"); - if (-f $rc_config_file) + $msg = "looking for configuration file " . $rc_config_file; + gp_message ("debug", $subr_name, $msg); + if (-f $rc_config_file) { - gp_message ("debug", $subr_name, "found configuration file $rc_config_file"); + $msg = "found configuration file " . $rc_config_file; + gp_message ("debug", $subr_name, $msg); $rc_file_found = $TRUE; last; } @@ -12787,21 +13874,26 @@ sub process_rc_file # There is no configuration file and we can skip this subroutine. #------------------------------------------------------------------------------ { - gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found"); + $msg = "configuration file $rc_file_name not found"; + gp_message ("verbose", $subr_name, $msg); return (0); } else { + $msg = "unable to open file $rc_config_file for reading:"; open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file") - or die ("$subr_name - unable to open file $rc_config_file for reading: $!"); + or die ($subr_name . " - " . $msg . " " . $!); #------------------------------------------------------------------------------ # The configuration file has been opened for reading. #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading"); + $msg = "file $rc_config_file has been opened for reading"; + gp_message ("debug", $subr_name, $msg); } - gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file"); - gp_message ("debug", $subr_name, "processing configuration file $rc_config_file"); + $msg = "found configuration file $rc_config_file"; + gp_message ("verbose", $subr_name, $msg); + $msg = "processing configuration file " . $rc_config_file; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Here we scan the configuration file for the settings. @@ -12846,8 +13938,8 @@ sub process_rc_file } #------------------------------------------------------------------------------ -# Split the input line using the "#" symbol as a separator. We have already -# handled the case of an isolated comment line, so there may only be an +# Split the input line using the "#" symbol as a separator. We have already +# handled the case of an isolated comment line, so there may only be an # embedded comment. # # Regardless of this, we are only interested in the first part. @@ -12869,8 +13961,8 @@ sub process_rc_file #------------------------------------------------------------------------------ { $parse_errors++; - $message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; - $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; + $msg = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; + $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; next; } else @@ -12889,17 +13981,18 @@ sub process_rc_file @my_fields = split (/\s/, $split_line[0]); $number_of_fields = scalar (@my_fields); - gp_message ("debug", $subr_name, "number of fields = $number_of_fields"); + $msg = "number of fields = " . $number_of_fields; + gp_message ("debug", $subr_name, $msg); } - if ($number_of_fields ge 3) + if ($number_of_fields ge 3) #------------------------------------------------------------------------------ # This is not supported. #------------------------------------------------------------------------------ { $parse_errors++; - $message = "more than 2 fields found: $first_part"; - $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; + $msg = "more than 2 fields found: $first_part"; + $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; next; } elsif ($number_of_fields eq 2) @@ -12914,12 +14007,13 @@ sub process_rc_file } else { - my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields"; + $msg = "[line $line_number] $rc_config_file -"; + $msg .= " number of fields = $number_of_fields"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ -# Store the keyword, value and line number. +# Store the keyword, value and line number. #------------------------------------------------------------------------------ if (exists ($rc_settings_user{$rc_keyword})) { @@ -12928,20 +14022,23 @@ sub process_rc_file my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"}; if ($rc_value ne $prev_value) { - $message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'"; + $msg = "option $rc_keyword previously set at line"; + $msg .= " $prev_line_number: new value '$rc_value'"; + $msg .= " ' overrides '$prev_value'"; } else { - $message = "option $rc_keyword previously set to the same value at line $prev_line_number"; + $msg = "option $rc_keyword previously set to the same value"; + $msg .= " at line $prev_line_number"; } - $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message; + $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $msg; } $rc_settings_user{$rc_keyword}{"value"} = $rc_value; $rc_settings_user{$rc_keyword}{"line_no"} = $line_number; - gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); - gp_message ("debug", $subr_name, "stored value = $rc_value"); - gp_message ("debug", $subr_name, "stored line number = $line_number"); + gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); + gp_message ("debug", $subr_name, "stored value = $rc_value"); + gp_message ("debug", $subr_name, "stored line number = $line_number"); } #------------------------------------------------------------------------------ @@ -12956,19 +14053,22 @@ sub process_rc_file for my $keyword (keys %rc_settings_user) { my $key_value = $rc_settings_user{$keyword}{"value"}; - gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value"); + $msg = "keyword = " . $keyword . " value = " . $key_value; + gp_message ("debug", $subr_name, $msg); } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { - gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); + $msg = "before config file: $rc_keyword $fields ="; + $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; + gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ -# We are almost done. Check for all keywords found whether they are valid. +# We are almost done. Check for all keywords found whether they are valid. # Also verify that the corresponding value is valid. # # Update the g_user_settings table if everything is okay. @@ -12986,7 +14086,7 @@ sub process_rc_file # - Check how many values it requires (currently exactly one is supported) # - Is the value a valid number or string? #------------------------------------------------------------------------------ - my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; + $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; if ($no_of_arguments eq 1) { @@ -12998,21 +14098,25 @@ sub process_rc_file #------------------------------------------------------------------------------ { my $data_type = $g_user_settings{$rc_keyword}{"data_type"}; - my $valid_input = verify_if_input_is_valid ($input_value, $data_type); + my $valid_input = + verify_if_input_is_valid ($input_value, $data_type); #------------------------------------------------------------------------------ # Check if the value is valid. #------------------------------------------------------------------------------ if ($valid_input) { - $g_user_settings{$rc_keyword}{"current_value"} = $rc_value; + $g_user_settings{$rc_keyword}{"current_value"} = + $rc_value; $g_user_settings{$rc_keyword}{"defined"} = $TRUE; } else { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; - $message = "input value '$input_value' for keyword $rc_keyword is not valid"; - $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; + $msg = "input value '$input_value' for keyword"; + $msg .= " $rc_keyword is not valid"; + $error_and_warning_msgs{"error"}{$line_number}{"message"} + = $msg; next; } } @@ -13023,8 +14127,9 @@ sub process_rc_file { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; - $message = "missing value for keyword '$rc_keyword'"; - $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; + $msg = "missing value for keyword '$rc_keyword'"; + $error_and_warning_msgs{"error"}{$line_number}{"message"} + = $msg; next; } } @@ -13054,39 +14159,45 @@ sub process_rc_file { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; - $message = "keyword $rc_keyword is not supported"; - $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; + $msg = "keyword $rc_keyword is not supported"; + $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; } } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { - gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); + $msg = "after config file: $rc_keyword $fields ="; + $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; + gp_message ("debug", $subr_name, $msg); } } print_table_user_settings ("debug", "upon the return from $subr_name"); if ( ($parse_errors == 0) and ($parse_warnings == 0) ) { - gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file"); + $msg = "successfully parsed and processed the configuration file"; + gp_message ("verbose", $subr_name, $msg); } else { if ($parse_errors > 0) { my $plural_or_single = ($parse_errors > 1) ? "errors" : "error"; - $message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:"; - gp_message ("debug", $subr_name, $message); + $msg = $g_error_keyword . "found $parse_errors fatal"; + $msg .= " " . $plural_or_single . " in the configuration file:"; + gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ -# Sort the hash keys, the line numbers, alphabetically and print the +# Sort the hash keys, the line numbers, alphabetically and print the # corresponding error messages. #------------------------------------------------------------------------------ - for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} })) + for my $line_no (sort {$a <=> $b} + (keys %{ $error_and_warning_msgs{"error"} })) { - $message = $g_error_keyword. "[line $line_no] in file $rc_config_file - "; - $message .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; - gp_message ("debug", $subr_name, $message); + $msg = $g_error_keyword . "[line $line_no] in file"; + $msg .= $rc_config_file . " - "; + $msg .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; + gp_message ("debug", $subr_name, $msg); } } @@ -13094,13 +14205,16 @@ sub process_rc_file { if ($parse_warnings > 0) { - $message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:"; - gp_message ("debug", $subr_name, $message); - for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} })) + $msg = $g_warn_keyword . " found $parse_warnings warnings in"; + $msg .= " the configuration file:"; + gp_message ("debug", $subr_name, $msg); + for my $line_no (sort {$a <=> $b} + (keys %{ $error_and_warning_msgs{"warning"} })) { - $message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - "; - $message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; - gp_message ("debug", $subr_name, $message); + $msg = $g_warn_keyword; + $msg .= " [line $line_no] in file $rc_config_file - "; + $msg .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; + gp_message ("debug", $subr_name, $msg); } } } @@ -13117,7 +14231,7 @@ sub process_source { my $subr_name = get_my_name (); - my ($number_of_metrics, $function_info_ref, + my ($number_of_metrics, $function_info_ref, $outputdir, $input_filename) = @_; my @function_info = @{ $function_info_ref }; @@ -13137,12 +14251,12 @@ sub process_source # Computed dynamically below. # TBD: Try to move this up. #------------------------------------------------------------------------------ - my $src_times_regex; - my $hot_lines_regex; - my $metric_regex; + my $src_times_regex; + my $hot_lines_regex; + my $metric_regex; my $metric_extra_regex; - my @components = (); + my @components = (); my @fields_in_line = (); my @file_contents = (); my @hot_source_lines = (); @@ -13150,37 +14264,37 @@ sub process_source my @modified_html = (); my @transposed_hot_lines = (); - my $colour_coded_line; - my $colour_coded_line_ref; + my $colour_coded_line; + my $colour_coded_line_ref; my $line_id; my $ignore_value; - my $func_name_in_src_file; + my $func_name_in_src_file; my $html_new_line = "<br>"; - my $input_line; + my $input_line; my $metric_values; - my $modified_html_ref; - my $modified_line; + my $modified_html_ref; + my $modified_line; my $is_empty; my $start_all_source; my $start_target_source; my $end_target_source; - my $output_line; + my $output_line; my $hot_line; my $src_line_no; - my $src_code_line; + my $src_code_line; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; - + my $file_title; - my $found_target; - my $html_dis_record; - my $html_end; + my $found_target; + my $html_dis_record; + my $html_end; my $html_header; - my $html_home; - my $rounded_percentage; - my $start_tracking; - my $threshold_line; + my $html_home; + my $rounded_percentage; + my $start_tracking; + my $threshold_line; my $base; my $boldface; @@ -13188,7 +14302,7 @@ sub process_source my $routine; my $LANG = $g_locale_settings{"LANG"}; - my $the_title = set_title ($function_info_ref, $input_filename, + my $the_title = set_title ($function_info_ref, $input_filename, "process source"); my $outfile = $input_filename . ".html"; @@ -13196,7 +14310,7 @@ sub process_source # Remove the .txt from file.<n>.src.txt #------------------------------------------------------------------------------ my $html_output_file = $input_filename; - $html_output_file =~ s/$txt_ext_regex/.html/; + $html_output_file =~ s/$txt_ext_regex/.html/; gp_message ("debug", $subr_name, "input_filename = $input_filename"); gp_message ("debug", $subr_name, "the_title = $the_title"); @@ -13267,7 +14381,7 @@ sub process_source # Open the input file with the source code #------------------------------------------------------------------------------ { - open (SRC_LISTING, "<", $input_filename) + open (SRC_LISTING, "<", $input_filename) or die ("$subr_name - unable to open file $input_filename for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $input_filename for reading"); } @@ -13315,7 +14429,7 @@ sub process_source # In both cases, the first line after the header has whitespace. This is # followed by either one of the following: # -# - <line_no>. +# - <line_no>. # - <Function: # # These are the characteristics we use below. @@ -13341,7 +14455,7 @@ sub process_source #------------------------------------------------------------------------------ { $modified_line = "<i>" . $input_line . "</i>"; - push (@modified_html, $modified_line); + push (@modified_html, $modified_line); } } #------------------------------------------------------------------------------ @@ -13387,7 +14501,7 @@ sub process_source gp_message ("debugXL", $subr_name, "found target function $routine"); gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine"); - gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); + gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); } } @@ -13406,7 +14520,7 @@ sub process_source #------------------------------------------------------------------------------ if (not $found_target) { - my $msg; + my $msg; gp_message ("debug", $subr_name, "target function $routine not found"); $msg = "function $routine not found in $base - " . @@ -13423,8 +14537,8 @@ sub process_source { $end_target_source = $#file_contents; } - gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); - gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); + gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); + gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source"); #------------------------------------------------------------------------------ @@ -13446,7 +14560,7 @@ sub process_source { gp_message ("debugXL", $subr_name, " $line_number : found a hot line"); #------------------------------------------------------------------------------ -# We found a hot line and the metric fields are stored in $2. We turn this +# We found a hot line and the metric fields are stored in $2. We turn this # string into an array and add it as a row to hot_source_lines. #------------------------------------------------------------------------------ $hot_line = $1; @@ -13467,10 +14581,10 @@ sub process_source #------------------------------------------------------------------------------ for my $row (keys @hot_source_lines) { - my $msg = "row[" . $row . "] = "; + my $msg = "row[" . $row . "] ="; for my $col (keys @{$hot_source_lines[$row]}) { - $msg .= "$hot_source_lines[$row][$col] "; + $msg .= " $hot_source_lines[$row][$col]"; $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col]; } } @@ -13481,10 +14595,10 @@ sub process_source #------------------------------------------------------------------------------ for my $row (keys @transposed_hot_lines) { - my $msg = "row[" . $row . "] = "; + my $msg = "row[" . $row . "] ="; for my $col (keys @{$transposed_hot_lines[$row]}) { - $msg .= "$transposed_hot_lines[$row][$col] "; + $msg .= " $transposed_hot_lines[$row][$col]"; } gp_message ("debugXL", $subr_name, "hot lines = $msg"); } @@ -13519,11 +14633,11 @@ sub process_source #------------------------------------------------------------------------------ # Process those functions that are not the current target. #------------------------------------------------------------------------------ - $modified_html_ref = process_non_target_source ($start_all_source, + $modified_html_ref = process_non_target_source ($start_all_source, $start_target_source-1, $src_times_regex, - $function_regex, - $number_of_metrics, + $function_regex, + $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; @@ -13537,8 +14651,8 @@ sub process_source $routine, \@max_metric_values, $src_times_regex, - $function2_regex, - $number_of_metrics, + $function2_regex, + $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; @@ -13548,8 +14662,8 @@ sub process_source $modified_html_ref = process_non_target_source ($end_target_source+1, $#file_contents, $src_times_regex, - $function_regex, - $number_of_metrics, + $function_regex, + $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; @@ -13562,14 +14676,17 @@ sub process_source # # TBD: The same is done in generate_dis_html but should be done only once. #------------------------------------------------------------------------------ - if ($hp_value > 0) + if ($hp_value > 0) { my $rounded_percentage = sprintf ("%.1f", $hp_value); - $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; + $threshold_line = "<i>The setting for the highlight percentage"; + $threshold_line .= " (--highlight-percentage) option:"; + $threshold_line .= " " . $rounded_percentage . " (%)</i>"; } else { - $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; + $threshold_line = "<i>The highlight percentage feature has not been"; + $threshold_line .= " enabled</i>"; } $html_home = ${ generate_home_link ("left") }; @@ -13597,7 +14714,7 @@ sub process_source } close (NEW_HTML); close (SRC_LISTING); - + return ($found_target); } #-- End of subroutine process_source @@ -13640,9 +14757,9 @@ sub process_target_source #------------------------------------------------------------------------------ $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; - $line_id = extract_source_line_number ($src_times_regex, - $function2_regex, - $number_of_metrics, + $line_id = extract_source_line_number ($src_times_regex, + $function2_regex, + $number_of_metrics, $input_line); gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id"); @@ -13660,8 +14777,8 @@ sub process_target_source gp_message ("debug", $subr_name, "function_name = $2"); my $function_line = "<Function: " . $func_name_in_file . ">"; my $color_function_name = color_string ( - $function_line, - $boldface, + $function_line, + $boldface, $g_html_color_scheme{"target_function_name"}); my $ftag; if (exists ($g_function_tag_id{$target_function})) @@ -13702,7 +14819,7 @@ sub process_target_source { @components = split (" ", $input_line, 1+$number_of_metrics+2); $modified_line = set_background_color_string ( - $input_line, + $input_line, $g_html_color_scheme{"background_color_hot"}); } else @@ -13760,24 +14877,25 @@ 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 $abs_path_dir; + my @candidate_ignored_metrics = (); + my $error_code; + my $hp_value; + my $msg; my $outputdir; my $target_cmd; - my $rm_output_msg; + my $rm_output_msg; my $mkdir_output_msg; - my $time_percentage_multiplier; + my $time_percentage_multiplier; my $process_all_functions; - my $option_errors = 0; - #------------------------------------------------------------------------------ # The -o and -O options are mutually exclusive. #------------------------------------------------------------------------------ @@ -13788,81 +14906,140 @@ sub process_user_options if ($define_new_output_dir and $overwrite_output_dir) { - my $msg; - $msg = "the -o/--output and -O/--overwrite options are both set, " . "but are mutually exclusive"; - push (@g_user_input_errors, $msg); + gp_message ("error", $subr_name, $msg); $msg = "(setting for -o = $dir_o_option, " . "setting for -O = $dir_O_option)"; - push (@g_user_input_errors, $msg); + gp_message ("error", $subr_name, $msg); - $option_errors++; + $g_total_error_count++; } #------------------------------------------------------------------------------ -# Define the quiet mode. While this is an on/off keyword in the input, we -# use a boolean in the remainder, because it reads easier. +# The warnings option is deprecated. Print a warning to this extent and point +# to the --nowarnings option. #------------------------------------------------------------------------------ - my $quiet_value = $g_user_settings{"quiet"}{"current_value"}; - $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE; - #------------------------------------------------------------------------------ -# In quiet mode, all verbose, warnings and debug messages are suppressed. +# Handle the situation that both or one of the highlight-percentage and hp +# options are set. #------------------------------------------------------------------------------ - if ($g_quiet) + if ($g_user_settings{"warnings"}{"defined"}) { - $g_user_settings{"verbose"}{"current_value"} = "off"; - $g_user_settings{"warnings"}{"current_value"} = "off"; - $g_user_settings{"debug"}{"current_value"} = "off"; - $g_verbose = $FALSE; - $g_warnings = $FALSE; - my $debug_off = "off"; - my $ignore_value = set_debug_size (\$debug_off); + $msg = "<br>" . "the --warnings option has been deprecated and"; + $msg .= " will be ignored"; + gp_message ("warning", $subr_name, $msg); + + if ($g_user_settings{"nowarnings"}{"defined"}) + { + $msg = "since the --nowarnings option is also used, warnings"; + $msg .= " are disabled"; + gp_message ("warning", $subr_name, $msg); + } + else + { + $msg = "by default, warnings are enabled and can be disabled with"; + gp_message ("warning", $subr_name, $msg); + $msg = " the --nowarnings option"; + gp_message ("warning", $subr_name, $msg); + } + $g_total_warning_count++; } - else - { + #------------------------------------------------------------------------------ -# Get the verbose mode. +# In case both the --highlight-percentage and -hp option are set, issue a +# warning and continue with the --highlight-percentage value. #------------------------------------------------------------------------------ - my $verbose_value = $g_user_settings{"verbose"}{"current_value"}; - $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE; + if ($g_user_settings{"hp"}{"defined"}) + { + $msg = "<br>" . "the -hp option has been deprecated and"; + $msg .= " will be ignored"; + gp_message ("warning", $subr_name, $msg); + + if ($g_user_settings{"highlight_percentage"}{"defined"}) + { + $msg = "since the --highlight-percentage option is also used,"; + $msg .= " the value of "; + $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; + $msg .= " will be applied"; + gp_message ("warning", $subr_name, $msg); + } + else + { #------------------------------------------------------------------------------ -# Get the warning mode. +# If only the -hp option is set, we use it, because we do not want to break +# compatibility (yet) and force the user to change the option. #------------------------------------------------------------------------------ - my $warning_value = $g_user_settings{"warnings"}{"current_value"}; - $g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE; + +## FUTURE $msg = "instead, the default setting of " +## FUTURE $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; +## FUTURE $msg .= " for the --highlight-percentage will be used"; +## FUTURE gp_message ("warning", $subr_name, $msg); + +## FUTURE $msg = "please use this option to set the highlighting value"; +## FUTURE gp_message ("warning", $subr_name, $msg); + + $g_user_settings{"highlight_percentage"}{"current_value"} = + $g_user_settings{"hp"}{"current_value"}; + + $g_user_settings{"highlight_percentage"}{"defined"} = $TRUE; + + $msg = "for now, the value of " . + $g_user_settings{"hp"}{"current_value"} . + " for the -hp option is used, but please change the" . + " option to --highlight-percentage"; + gp_message ("warning", $subr_name, $msg); + } + + $g_total_warning_count++; } #------------------------------------------------------------------------------ -# The value for HP should be in the interval (0,100]. We already enforced +# Regardless of the use of the -hp option, we continue with the value for +# highlight-percentage. Some more checks are carried out now. +#------------------------------------------------------------------------------ + +#------------------------------------------------------------------------------ +# This value should be in the interval [0,100]. # the number to be positive, but the limits have not been checked yet. #------------------------------------------------------------------------------ - my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; + $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; if (($hp_value < 0) or ($hp_value > 100)) { - my $msg = "the value for the highlight percentage is set to $hp_value, "; - $msg .= "but must be in the range [0, 100]"; - push (@g_user_input_errors, $msg); + $msg = "the value for the highlight percentage is set to $hp_value,"; + $msg .= " but must be in the range [0, 100]"; + gp_message ("error", $subr_name, $msg); - $option_errors++; + $g_total_error_count++; + } + elsif ($hp_value == 0.0) +#------------------------------------------------------------------------------ +# A value of zero is interpreted to mean that highlighting should be disabled. +# To make the checks for this later on easier, set it to an integer value of 0. +#------------------------------------------------------------------------------ + { + $g_user_settings{"highlight_percentage"}{"current_value"} = 0; + + $msg = "reset the highlight percentage value from 0.0 to"; + $msg .= " " . $g_user_settings{"highlight_percentage"}{"current_value"}; + gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ -# The value for TP should be in the interval (0,100]. We already enforced +# The value for TP should be in the interval (0,100]. We already enforced # the number to be positive, but the limits have not been checked yet. #------------------------------------------------------------------------------ my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"}; if (($tp_value < 0) or ($tp_value > 100)) { - my $msg = "the value for the total percentage is set to $tp_value, " . - "but must be in the range (0, 100]"; - push (@g_user_input_errors, $message); + $msg = "the value for the total percentage is set to $tp_value,"; + $msg .= " but must be in the range (0, 100]"; + gp_message ("error", $subr_name, $msg); - $option_errors++; + $g_total_error_count++; } else { @@ -13879,13 +15056,12 @@ sub process_user_options $process_all_functions = $FALSE; } - my $txt; - $txt = "value of time_percentage_multiplier = " . - $time_percentage_multiplier; - gp_message ("debugM", $subr_name, $txt); - $txt = "value of process_all_functions = " . + $msg = "value of time_percentage_multiplier = " . + $time_percentage_multiplier; + gp_message ("debugM", $subr_name, $msg); + $msg = "value of process_all_functions = " . ($process_all_functions ? "TRUE" : "FALSE"); - gp_message ("debugM", $subr_name, $txt); + gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ @@ -13894,11 +15070,9 @@ sub process_user_options # to be excluded metrics as an index. The value of $TRUE assigned does not # really matter. #------------------------------------------------------------------------------ - my @candidate_ignored_metrics; - if ($g_user_settings{"ignore_metrics"}{"defined"}) { - @candidate_ignored_metrics = + @candidate_ignored_metrics = split (":", $g_user_settings{"ignore_metrics"}{"current_value"}); } for my $metric (@candidate_ignored_metrics) @@ -13908,34 +15082,28 @@ sub process_user_options } for my $metric (keys %ignored_metrics) { - my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; - gp_message ("debugM", $subr_name, $txt); + my $msg = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; + gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ -# Check if the experiment directories exist. +# Check if the experiment directories exist and if they do, add the absolute +# path. This is easier in the remainder. #------------------------------------------------------------------------------ for my $i (0 .. $#exp_dir_list) { if (-d $exp_dir_list[$i]) { - my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); + $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); $exp_dir_list[$i] = $abs_path_dir; - my $txt = "directory $exp_dir_list[$i] exists"; - gp_message ("debugM", $subr_name, $txt); - } - else - { - my $msg = "directory $exp_dir_list[$i] does not exist"; - push (@g_user_input_errors, $msg); - $option_errors++; + $msg = "directory $exp_dir_list[$i] exists"; + gp_message ("debugM", $subr_name, $msg); } } - return ($option_errors, \%ignored_metrics, $outputdir, - $time_percentage_multiplier, $process_all_functions, - \@exp_dir_list); + return (\%ignored_metrics, $outputdir, $time_percentage_multiplier, + $process_all_functions, \@exp_dir_list); } #-- End of subroutine process_user_options @@ -14008,7 +15176,7 @@ sub retrieve_metric_description #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ -sub rnumerically +sub rnumerically { my ($f1,$f2); if ($a =~ /^([^\d]*)(\d+)/) @@ -14019,8 +15187,8 @@ sub rnumerically $f2 = int ($2); $f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1); } - } - else + } + else { return ($b <=> $a); } @@ -14040,7 +15208,7 @@ sub set_arch_and_regexes gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); - if ($arch_uname eq "x86_64") + if ($arch_uname eq "x86_64") { #x86/x64 hardware uses jump $architecture_supported = $TRUE; @@ -14057,10 +15225,10 @@ sub set_arch_and_regexes $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)'; $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)'; } -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # TBD: Remove the elsif block -#------------------------------------------------------------------------------- - elsif ($arch_uname=~m/sparc/s) +#------------------------------------------------------------------------------ + elsif ($arch_uname=~m/sparc/s) { #sparc hardware uses branch $architecture_supported = $FALSE; @@ -14076,7 +15244,7 @@ sub set_arch_and_regexes $g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$'; $g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)'; } - else + else { $architecture_supported = $FALSE; gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality"); @@ -14104,7 +15272,7 @@ sub set_background_color_string $msg = "color = $color input_string = $input_string"; gp_message ("debugXL", $subr_name, $msg); - $background_color_string = "<span style='background-color: " . $color . + $background_color_string = "<span style='background-color: " . $color . "'>" . $input_string . "</span>"; $msg = "color = $color background_color_string = " . @@ -14123,20 +15291,12 @@ 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; + my $debug_value = lc ($g_user_settings{"debug"}{"current_value"}); #------------------------------------------------------------------------------ -# By default, set the value to "on", but correct below if needed. +# Set the corresponding sizes in the table. A value of "on" is equivalent to +# size "s". #------------------------------------------------------------------------------ - $g_user_settings{"debug"}{"current_value"} = "on"; - if (($debug_value eq "on") or ($debug_value eq "s")) { $g_debug_size{"on"} = $TRUE; @@ -14168,7 +15328,8 @@ sub set_debug_size # Any other value is considered to disable debugging. #------------------------------------------------------------------------------ { - $g_user_settings{"debug"}{"current_value"} = "off"; +## $g_user_settings{"debug"}{"current_value"} = "off"; + $g_debug = $FALSE; $g_debug_size{"on"} = $FALSE; $g_debug_size{"s"} = $FALSE; $g_debug_size{"m"} = $FALSE; @@ -14179,13 +15340,18 @@ sub set_debug_size #------------------------------------------------------------------------------ # Activate in case of an emergency :-) #------------------------------------------------------------------------------ -## if ($g_debug_size{$debug_value}) -## { -## for my $i (keys %g_debug_size) -## { -## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; -## } -## } + my $show_sizes = $FALSE; + + if ($show_sizes) + { + if ($g_debug_size{$debug_value}) + { + for my $i (keys %g_debug_size) + { + print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; + } + } + } return (0); @@ -14223,7 +15389,7 @@ sub set_default_metrics gp_message ("debug", $subr_name,"the value of metric_line = $metric_line"); #------------------------------------------------------------------------------ -# Decode the metric part of the input line. If a valid line, return the +# Decode the metric part of the input line. If a valid line, return the # metric components. Otherwise return "skipped" in the metric_spec field. #------------------------------------------------------------------------------ my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line); @@ -14277,14 +15443,14 @@ sub set_default_metrics $detail_metrics = $summary_metrics; $detail_metrics_system = $summary_metrics; - return (\%metric_description, \%metric_found, + return (\%metric_description, \%metric_found, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); } #-- End of subroutine set_default_metrics #------------------------------------------------------------------------------ # Set various system specific variables. These depend upon both the processor -# architecture and OS. The values are stored in global structure +# architecture and OS. The values are stored in global structure # g_arch_specific_settings. #------------------------------------------------------------------------------ sub set_system_specific_variables @@ -14295,14 +15461,14 @@ sub set_system_specific_variables my $elf_arch; my $read_elf_cmd; - my $elf_support; + my $elf_support; my $architecture_supported; my $arch; my $regex; my $subexp; my $linksubexp; - if ($arch_uname eq "x86_64") + if ($arch_uname eq "x86_64") { #------------------------------------------------------------------------------ # x86/x64 hardware uses jump @@ -14328,7 +15494,7 @@ sub set_system_specific_variables $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)'; $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)'; } - else + else { $architecture_supported = $FALSE; $g_arch_specific_settings{"arch_supported"} = $FALSE; @@ -14337,12 +15503,12 @@ sub set_system_specific_variables #------------------------------------------------------------------------------ # TBD Ruud: need to handle this better #------------------------------------------------------------------------------ - if ($arch_uname_s eq "Linux") + if ($arch_uname_s eq "Linux") { $elf_arch = $arch_uname_s; $read_elf_cmd = $g_mapped_cmds{"readelf"}; - if ($read_elf_cmd eq "road_to_nowhere") + if ($read_elf_cmd eq "road to nowhere") { $elf_support = $FALSE; } @@ -14351,8 +15517,8 @@ sub set_system_specific_variables $elf_support = $TRUE; } gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch"); - } - else + } + else { gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported"); } @@ -14376,6 +15542,7 @@ sub set_title my $base; my $first_line; + my $file_is_empty; my $src_file; my $RI; my $the_title; @@ -14405,7 +15572,7 @@ sub set_title } } $the_title = "Source"; - } + } elsif ($from_where eq "disassembly") { if ($base =~ /^file\.(\d+)\.dis$/) @@ -14421,8 +15588,8 @@ sub set_title } } $the_title = "Disassembly"; - } - else + } + else { $msg = "called from unknown routine - $from_where"; gp_message ("assertion", $subr_name, $msg); @@ -14432,18 +15599,18 @@ sub set_title { $routine = $function_info[$RI]{"routine"}; } - + if ($from_where eq "process source") { - my $is_empty = is_file_empty ($filename); + $file_is_empty = is_file_empty ($filename); - if ($is_empty) + if ($file_is_empty) { $src_file = ""; } else { - open ($SRC, "<", $filename) + open ($SRC, "<", $filename) or die ("$subr_name - unable to open source file $filename for reading:'$!'"); gp_message ("debug", $subr_name, "opened file $filename for reading"); @@ -14466,13 +15633,31 @@ sub set_title } elsif ($from_where eq "disassembly") { + $msg = "unable to open disassembly file $filename for reading:"; open ($DIS, "<", $filename) - or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); + or die ($subr_name . " - " . $msg . " " . $!); gp_message ("debug", $subr_name, "opened file $filename for reading"); - $first_line = <$DIS>; + $file_is_empty = is_file_empty ($filename); + + if ($file_is_empty) +#------------------------------------------------------------------------------ +# Currently, the disassembly file for <static> functions appears to be empty +# on aarch64. This might be a bug, but it is in any case better to handle +# this situation. +#------------------------------------------------------------------------------ + { + $first_line = ""; + $msg = "file $filename is empty"; + gp_message ("debugM", $subr_name, $msg); + } + else + { + $first_line = <$DIS>; + } + close ($DIS); - + if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) { $src_file = "$1" @@ -14493,8 +15678,8 @@ sub set_title if ($src_file ne "(unknown)") { $the_title .= " ($src_file)"; - } - else + } + else { $the_title .= " $src_file"; } @@ -14505,34 +15690,32 @@ sub set_title } #-- End of subroutine set_title #------------------------------------------------------------------------------ -# Handles where the output should go. If needed, a directory is # created -# where the results will go. +# Handles where the output should go. If needed, a directory to store the +# results in is created. #------------------------------------------------------------------------------ sub set_up_output_directory { my $subr_name = get_my_name (); my $error_code; - my $message; + my $msg; my $mkdir_output_msg; - my $option_errors; my $outputdir = "does_not_exist_yet"; my $rm_output_msg; + my $success; my $target_cmd; my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; - $option_errors = 0; - if ((not $define_new_output_dir) and (not $overwrite_output_dir)) #------------------------------------------------------------------------------ -# If neither -o or -O are set, find the next number to be used in the name for +# If neither -o or -O are set, find the next number to be used in the name for # the default output directory. #------------------------------------------------------------------------------ { my $dir_id = 1; - while (-d "display.".$dir_id.".html") + while (-d "display.".$dir_id.".html") { $dir_id++; } $outputdir = "display.".$dir_id.".html"; } @@ -14554,7 +15737,8 @@ sub set_up_output_directory #------------------------------------------------------------------------------ # The name of the output directory is known and we can proceed. #------------------------------------------------------------------------------ - gp_message ("debug", $subr_name, "the target output directory is $outputdir"); + $msg = "the target output directory is $outputdir"; + gp_message ("debug", $subr_name, $msg); if (-d $outputdir) { @@ -14563,35 +15747,38 @@ sub set_up_output_directory #------------------------------------------------------------------------------ if ($define_new_output_dir) { - $message = "directory $outputdir already exists"; - $message .= " (use the -O option to overwrite an existing directory)"; - push (@g_user_input_errors, $message); + $msg = "directory $outputdir already exists"; + gp_message ("error", $subr_name, $msg); + $msg = "use the -O/--overwite option to overwrite an"; + $msg .= " existing directory"; + gp_message ("error", $subr_name, $msg); - $option_errors++; + $g_total_error_count++; + + gp_message ("abort", $subr_name, $g_abort_msg); - return ($option_errors, $outputdir); } elsif ($overwrite_output_dir) #------------------------------------------------------------------------------ # It is a bit risky to remove this directory and so we proceed with caution. # What if the user decides to call it "*" e.g. "-O \*" for example? While this -# should have been caught when processing the options, we still like to +# should have been caught when processing the options, we still like to # be very cautious here before executing /bin/rm -rf. #------------------------------------------------------------------------------ { - if ($outputdir eq "*") + if ($outputdir eq "*") { - $message = "it is not allowed to use * as a value for the -O option"; - push (@g_user_input_errors, $message); + $msg = "it is not allowed to use * as a value for the -O option"; + gp_message ("error", $subr_name, $msg); - $option_errors++; + $g_total_error_count++; - return ($option_errors, $outputdir); + gp_message ("abort", $subr_name, $g_abort_msg); } else { #------------------------------------------------------------------------------ -# The output directory exists, but it is okay to overwrite it. It is +# The output directory exists, but it is okay to overwrite it. It is # removed here and created again below. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir; @@ -14599,36 +15786,48 @@ sub set_up_output_directory if ($error_code != 0) { + $msg = "fatal error when trying to remove $outputdir"; gp_message ("error", $subr_name, $rm_output_msg); - gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + + gp_message ("abort", $subr_name, $g_abort_msg); } else { - gp_message ("debug", $subr_name, "directory $outputdir has been removed"); + $msg = "directory $outputdir has been removed"; + gp_message ("debug", $subr_name, $msg); } } } } #-- End of if-check for $outputdir -#------------------------------------------------------------------------------- -# When we get here, the fatal scenarios have been cleared and the name for +#------------------------------------------------------------------------------ +# When we get here, the fatal scenarios have not occurred and the name for # $outputdir is known. Time to create it. Note that recursive creation is -# supported and umask controls the access permissions. -#------------------------------------------------------------------------------- +# supported and the user umask settings control the access permissions. +#------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir; ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd); if ($error_code != 0) { - my $msg = "a fatal problem occurred when creating directory $outputdir"; - gp_message ("abort", $subr_name, $msg); + $msg = "a fatal problem occurred when creating directory $outputdir"; + gp_message ("error", $subr_name, $mkdir_output_msg); + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + + gp_message ("abort", $subr_name, $g_abort_msg); } else { - gp_message ("debug", $subr_name, "created output directory $outputdir"); + $msg = "created output directory $outputdir"; + gp_message ("debug", $subr_name, $msg); } - return ($option_errors, $outputdir); + return ($outputdir); } #-- End of subroutine set_up_output_directory @@ -14644,8 +15843,9 @@ sub tag_name #------------------------------------------------------------------------------ # Keeps track how many names have been tagged already. #------------------------------------------------------------------------------ - state $S_total_tagged_names = 0; + state $S_total_tagged_names = 0; + my $msg; my $unique_name; gp_message ("debug", $subr_name, "target_name on entry = $target_name"); @@ -14663,21 +15863,32 @@ sub tag_name #------------------------------------------------------------------------------ # Remove inlining info #------------------------------------------------------------------------------ - $target_name =~ s/, instructions from source file.*//; + $target_name =~ s/, instructions from source file.*//; if (defined $g_tagged_names{$target_name}) { - gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}"); - gp_message ("debug", $subr_name, "target_name on return = $target_name"); + $msg = "target_name = $target_name is already defined: "; + $msg .= $g_tagged_names{$target_name}; + gp_message ("debug", $subr_name, $msg); + + $msg = "target_name on return = $target_name"; + gp_message ("debug", $subr_name, $msg); + return ($g_tagged_names{$target_name}); } else { $unique_name = "ftag".$S_total_tagged_names; - $S_total_tagged_names++; + $S_total_tagged_names++; $g_tagged_names{$target_name} = $unique_name; - gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}"); - gp_message ("debug", $subr_name, "target_name on return = $target_name"); + + $msg = "target_name = $target_name is new and added: "; + $msg .= "g_tagged_names{$target_name} = $g_tagged_names{$target_name}"; + gp_message ("debug", $subr_name, $msg); + + $msg = "target_name on return = $target_name"; + gp_message ("debug", $subr_name, $msg); + return ($unique_name); } @@ -14699,11 +15910,11 @@ sub terminate_html_document } #-- 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 (); @@ -14714,15 +15925,16 @@ sub verify_consistency_experiments my $executable_name; my $full_path_executable_name; + my $msg; my $ref_executable_name; my $first_exp_dir = $TRUE; my $count_differences = 0; -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ # Enforce that the full path names to the executable are the same. This could # be overkill and a checksum approach would be more flexible. -#------------------------------------------------------------------------------- +#------------------------------------------------------------------------------ for my $full_exp_dir (@exp_dir_list) { my $exp_dir = get_basename ($full_exp_dir); @@ -14730,17 +15942,23 @@ sub verify_consistency_experiments if ($first_exp_dir) { $first_exp_dir = $FALSE; - $ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; - gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name"); + $ref_executable_name = + $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; + $msg = "ref_executable_name = " . $ref_executable_name; + gp_message ("debug", $subr_name, $msg); next; } - $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; - gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name"); + $full_path_executable_name = + $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; + $msg = "full_path_executable_name = " . $full_path_executable_name; + gp_message ("debug", $subr_name, $msg); if ($full_path_executable_name ne $ref_executable_name) { $count_differences++; - gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name"); + $msg = $full_path_executable_name . " does not match"; + $msg .= " " . $ref_executable_name; + gp_message ("debug", $subr_name, $msg); } } @@ -14752,7 +15970,7 @@ sub 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 +# verified in the context of gprofng. The definition for the metrics is a # good example of that. #------------------------------------------------------------------------------ sub verify_if_input_is_valid @@ -14761,6 +15979,7 @@ sub verify_if_input_is_valid my ($input_item, $data_type) = @_; + my $msg; my $return_value = $FALSE; #------------------------------------------------------------------------------ @@ -14799,7 +16018,7 @@ sub verify_if_input_is_valid } elsif ($data_type eq "metric_names") #------------------------------------------------------------------------------ -# A gprofng metric definition but without the flavour and visibility . Either +# A gprofng metric definition but without the flavour and visibility . Either # the name consists of "default" only, or a keyword with lowercase letters # only. This pattern may be repeated with a ":" as the separator. #------------------------------------------------------------------------------ @@ -14827,7 +16046,7 @@ sub verify_if_input_is_valid # This can be almost anything, including "/" and "." #------------------------------------------------------------------------------ { - if ($input_item =~ /^[\w\/\.]*$/) + if ($input_item =~ /^[\w\/\.\-]*$/) { $return_value = $TRUE; } @@ -14854,7 +16073,7 @@ sub verify_if_input_is_valid } elsif ($data_type eq "size") #------------------------------------------------------------------------------ -# Supported values are "on", "off", "s", "m", "l", OR "xl". +# Supported values are "on", "off", "s", "m", "l", or "xl". #------------------------------------------------------------------------------ { if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/) @@ -14910,10 +16129,118 @@ sub verify_if_input_is_valid } else { - my $msg = "the $data_type data type for input $input_item is not supported"; + $msg = "the $data_type data type for input $input_item is not supported"; gp_message ("assertion", $subr_name, $msg); - } + } return ($return_value); } #-- End of subroutine verify_if_input_is_valid + +#------------------------------------------------------------------------------ +# Scan the leftovers in ARGV. Other than the option generated by the driver, +# this list should be empty. Anything left here is considered to be a fatal +# error and pushed into the g_error_msgs buffer. +# +# We use two different arrays for the errors found. This allows us to group +# the same type of errors. +#------------------------------------------------------------------------------ +sub wrap_up_user_options +{ + my $subr_name = get_my_name (); + + my @opt_unsupported = (); + my @opt_ignored = (); + + my $current_option; + my $driver_inserted = "--whoami=gprofng display html"; + my $ignore_option; + my $msg; + my $option_delimiter = "--"; + + if (@ARGV) + { + $msg = "items in ARGV: " . join (" ", @ARGV); + gp_message ("debugXL", $subr_name, $msg); + + $ignore_option = $FALSE; + for my $i (keys @ARGV) + { + $current_option = $ARGV[$i]; + + $msg = "ARGV[$i] = $current_option"; + + if ($current_option eq $option_delimiter) +#------------------------------------------------------------------------------ +# The user may use a feature of GetOptions to delimit the options. After +# this, only experiment names are allowed and these have been handled already, +# so anything found after this delimite is an error. +# +# This is why we set a flag if the delimiter has been found. +#------------------------------------------------------------------------------ + { + $ignore_option = $TRUE; + gp_message ("debugXL", $subr_name, $msg . " (option delimiter)"); + } + elsif ($ignore_option) +#------------------------------------------------------------------------------ +# We have seen the delimiter, but there are still options, or other strings. +# In any case, it is not allowed. +#------------------------------------------------------------------------------ + { + push (@opt_ignored, $current_option); + gp_message ("debugXL", $subr_name, $msg . " (ignored)"); + } + elsif ($current_option ne $driver_inserted) +#------------------------------------------------------------------------------ +# The gprofng driver inserts this and it should be ignored. This is why we +# only recorded those options different than the one inserted by the driver. +#------------------------------------------------------------------------------ + { + push (@opt_unsupported, $current_option); + gp_message ("debugXL", $subr_name, $msg . " (unsupported)"); + } + else +#------------------------------------------------------------------------------ +# The gprofng driver inserts this option and it should be ignored. +#------------------------------------------------------------------------------ + { + gp_message ("debugXL", $subr_name, $msg . + " (driver inserted and ignored)"); + } + } + } + +#------------------------------------------------------------------------------ +# Store any illegal input in the g_error_msgs buffer. +#------------------------------------------------------------------------------ + if (@opt_ignored) + { + $msg = "the following input is out of place:"; + for my $i (keys @opt_ignored) + { + $msg .= " " . $opt_ignored[$i]; + } + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + } + if (@opt_unsupported) + { + $msg = "the following items in the input are not supported:"; + for my $i (keys @opt_unsupported) + { + $msg .= " " . $opt_unsupported[$i]; + } + gp_message ("error", $subr_name, $msg); + + $msg = "perhaps an error in the option name, or an option value"; + $msg .= " is missing?"; + gp_message ("error", $subr_name, $msg); + + $g_total_error_count++; + } + + return (0); + +} #-- End of subroutine wrap_up_user_options |