JezK
Edit File: gp-display-html
#!/usr/bin/perl # Copyright (C) 2021-2023 Free Software Foundation, Inc. # Contributed by Oracle. # # This file is part of GNU Binutils. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, 51 Franklin Street - Fifth Floor, Boston, # MA 02110-1301, USA. use strict; use warnings; use feature qw (state); use File::stat; #------------------------------------------------------------------------------ # Check as early as possible if the version of Perl used is supported. #------------------------------------------------------------------------------ INIT { my $perl_minimal_version_supported = version->parse ("5.10.0")->normal; my $perl_current_version = version->parse ("$]")->normal; if ($perl_current_version lt $perl_minimal_version_supported) { my $msg; $msg = "Error: minimum Perl release required: "; $msg .= $perl_minimal_version_supported; $msg .= " current: "; $msg .= $perl_current_version; $msg .= "\n"; print $msg; exit (1); } } #-- End of INIT #------------------------------------------------------------------------------ # Poor man's version of a boolean. #------------------------------------------------------------------------------ my $TRUE = 1; my $FALSE = 0; #------------------------------------------------------------------------------ # Used to ensure correct alignment of columns. #------------------------------------------------------------------------------ my $g_max_length_first_metric; #------------------------------------------------------------------------------ # This variable contains the path used to execute $GP_DISPAY_TEXT. #------------------------------------------------------------------------------ my $g_path_to_tools; #------------------------------------------------------------------------------- # Code debugging flag #------------------------------------------------------------------------------- my $g_test_code = $FALSE; #------------------------------------------------------------------------------- # GPROFNG commands and files used. #------------------------------------------------------------------------------- my $GP_DISPLAY_TEXT = "gp-display-text"; my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log"; #------------------------------------------------------------------------------ # Global variables. #------------------------------------------------------------------------------ my $g_addressing_mode = "64 bit"; #------------------------------------------------------------------------------ # The global regex section. # # First step towards consolidating all regexes. #------------------------------------------------------------------------------ my $g_less_than_regex = '<'; my $g_html_less_than_regex = '<'; my $g_endbr_inst_regex = 'endbr[32|64]'; #------------------------------------------------------------------------------ # These are the regex's used. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Disassembly analysis #------------------------------------------------------------------------------ my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; #------------------------------------------------------------------------------ # Convenience. These map the on/off value to $TRUE/$FALSE to make the code # easier to read. For example: "if ($g_verbose)" as opposed to the following: # "if ($verbose_setting eq "on"). #------------------------------------------------------------------------------ my $g_verbose; my $g_warnings; my $g_quiet; my $g_first_metric; my $binutils_version; my $driver_cmd; my $tool_name; my $version_info; my %g_mapped_cmds = (); #------------------------------------------------------------------------------ # TBD All warning messages are collected and are accessible through the main # page. #------------------------------------------------------------------------------ my @g_warning_messages = (); #------------------------------------------------------------------------------ # Contains the names that have already been tagged. This is a global # structure because otherwise the code would get much more complicated. #------------------------------------------------------------------------------ my %g_tagged_names = (); #------------------------------------------------------------------------------ # TBD Remove the use of these structures. No longer used. #------------------------------------------------------------------------------ my %g_function_tag_id = (); my $g_context = 5; # Defines the range of scan my $g_default_setting_lang = "en-US.UTF-8"; my %g_exp_dir_meta_data; my @g_user_input_errors = (); my $g_html_credits_line; my $g_warn_keyword = "Input warning: "; my $g_error_keyword = "Input error: "; my %g_function_occurrences = (); my %g_map_function_to_index = (); my %g_multi_count_function = (); my %g_function_view_all = (); my @g_full_function_view_table = (); my @g_html_experiment_stats = (); #------------------------------------------------------------------------------- # These structures contain the information printed in the function views. #------------------------------------------------------------------------------- my $g_header_lines; my @g_html_function_name = (); #------------------------------------------------------------------------------- # TBD: This variable may not be needed and replaced by tp_value my $thresh = 0; #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- # Define the driver command, tool name and version number. #------------------------------------------------------------------------------- $driver_cmd = "gprofng display html"; $tool_name = "gp-display-html"; #$binutils_version = "2.38.50"; $binutils_version = "2.40.00"; $version_info = $tool_name . " GNU binutils version " . $binutils_version; #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- # Define several key data structures. #------------------------------------------------------------------------------- my %g_user_settings = ( output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE}, highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE}, threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE}, default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE}, verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE}, debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE}, quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, ); my %g_debug_size = ( "on" => $FALSE, "s" => $FALSE, "m" => $FALSE, "l" => $FALSE, "xl" => $FALSE, ); my %local_system_config = ( kernel_name => "undefined", nodename => "undefined", kernel_release => "undefined", kernel_version => "undefined", machine => "undefined", processor => "undefined", hardware_platform => "undefined", operating_system => "undefined", hostname_current => "undefined", ); # Note that we use single quotes here, because regular expressions wreak havoc otherwise. my %g_arch_specific_settings = ( arch_supported => $FALSE, arch => 'undefined', regex => 'undefined', subexp => 'undefined', linksubexp => 'undefined', ); my %g_locale_settings = ( LANG => "en_US.UTF-8", decimal_separator => "\\.", covert_to_dot => $FALSE ); #------------------------------------------------------------------------------ # See this page for a nice overview with the colors: # https://www.w3schools.com/colors/colors_groups.asp #------------------------------------------------------------------------------ my %g_html_color_scheme = ( "control_flow" => "Brown", "target_function_name" => "Red", "non_target_function_name" => "BlueViolet", "background_color_hot" => "PeachPuff", "background_color_lukewarm" => "LemonChiffon", "link_outside_range" => "Crimson", "error_message" => "LightPink", "background_color_page" => "White", # "background_color_page" => "LightGray", "background_selected_sort" => "LightSlateGray", "index" => "Lavender", ); #------------------------------------------------------------------------------ # These are the base names for the HTML files that are generated. #------------------------------------------------------------------------------ my %g_html_base_file_name = ( "caller_callee" => "caller-callee", "disassembly" => "dis", "experiment_info" => "experiment-info", "function_view" => "function-view-sorted", "index" => "index", "source" => "src", "warnings" => "warnings", ); #------------------------------------------------------------------------------ # This is cosmetic, but helps with the scoping of variables. #------------------------------------------------------------------------------ main (); exit (0); #------------------------------------------------------------------------------ # This is the driver part of the program. #------------------------------------------------------------------------------ sub main { my $subr_name = get_my_name (); #------------------------------------------------------------------------------ # The name of the configuration file. #------------------------------------------------------------------------------ my $rc_file_name = ".gp-display-html.rc"; #------------------------------------------------------------------------------ # OS commands executed and search paths. #------------------------------------------------------------------------------ my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls uname readelf mkdir); my @search_paths_os_cmds = qw ( /usr/bin /bin /usr/local/bin /usr/local/sbin /usr/sbin /sbin ); #------------------------------------------------------------------------------ # TBD: Eliminate these. #------------------------------------------------------------------------------ my $ARCHIVES_MAP_NAME; my $ARCHIVES_MAP_VADDR; #------------------------------------------------------------------------------ # Local structures (hashes and arrays). #------------------------------------------------------------------------------ my @exp_dir_list; # List with experiment directories my @metrics_data; my %function_address_info = (); my $function_address_info_ref; my @function_info = (); my $function_info_ref; my %function_address_and_index = (); my $function_address_and_index_ref; my %addressobjtextm = (); my $addressobjtextm_ref; my %addressobj_index = (); my $addressobj_index_ref; my %LINUX_vDSO = (); my $LINUX_vDSO_ref; my %function_view_structure = (); my $function_view_structure_ref; my %elf_rats = (); my $elf_rats_ref; #------------------------------------------------------------------------------ # Local variables. #------------------------------------------------------------------------------ my $abs_path_outputdir; my $archive_dir_not_empty; my $base_va_executable; my $executable_name; my $exp_dir_list_ref; my $found_exp_dir; my $ignore_value; my $message; my $number_of_metrics; my $va_executable_in_hex; my $failed_command_mappings; my $option_errors; my $total_user_errors; my $script_pc_metrics; my $dir_check_errors; my $consistency_errors; my $outputdir; my $return_code; my $decimal_separator; my $convert_to_dot; my $architecture_supported; my $elf_arch; my $elf_support; my $home_dir; my $elf_loadobjects_found; my $rc_file_paths_ref; my @rc_file_paths = (); my $rc_file_errors = 0; my @sort_fields = (); my $summary_metrics; my $call_metrics; my $user_metrics; my $system_metrics; my $wall_metrics; my $detail_metrics; my $detail_metrics_system; my $pretty_dir_list; my %metric_value = (); my %metric_description = (); my %metric_description_reversed = (); my %metric_found = (); my %ignored_metrics = (); my $metric_value_ref; my $metric_description_ref; my $metric_found_ref; my $ignored_metrics_ref; my @table_execution_stats = (); my $table_execution_stats_ref; my $html_first_metric_file_ref; my $html_first_metric_file; my $arch; my $subexp; my $linksubexp; my $setting_for_LANG; my $time_percentage_multiplier; my $process_all_functions; my $selected_archive; #------------------------------------------------------------------------------ # If no options are given, print the help info and exit. #------------------------------------------------------------------------------ if ($#ARGV == -1) { $ignore_value = print_help_info (); return (0); } #------------------------------------------------------------------------------ # This part is like a preamble. Before we continue we need to figure out some # things that are needed later on. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Store the absolute path of the command executed. #------------------------------------------------------------------------------ my $location_gp_command = $0; #------------------------------------------------------------------------------ # The very first thing to do is to quickly determine if the user has enabled # one of the following options and take action accordingly: # --version, --verbose, --debug, --quiet # # This avoids that there is a gap between the start of the execution and the # moment the options are parsed, checked, and interpreted. # # When parsing the full command line, these options will be more extensively # checked and also updated in %g_user_settings # Note that a confirmation message, if any, is printed here and not when the # options are parsed and processed. #------------------------------------------------------------------------------ $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; $ignore_value = early_scan_specific_options (); #------------------------------------------------------------------------------ # The next subroutine is executed early to ensure the OS commands we need are # available. # # This subroutine stores the commands and the full path names as an associative # array called "g_mapped_cmds". The command is the key and the value is the full # path. For example: ("uname", /usr/bin/uname). #------------------------------------------------------------------------------ $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds); if ($failed_command_mappings == 0) { gp_message ("debug", $subr_name, "verified the OS commands"); } else { my $msg = "failure in the verification of the OS commands"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Get the home directory and the locations for the configuration file on the # current system. #------------------------------------------------------------------------------ ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); @rc_file_paths = @{ $rc_file_paths_ref }; gp_message ("debug", $subr_name, "the home directory is $home_dir"); gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths"); $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); #------------------------------------------------------------------------------ # Get the ball rolling. Parse and interpret the configuration file (if any) # and the command line options. # # If either $rc_file_errors or $total_user_errors, or both, are non-zero it # means a fatal error has occured. In this case, all error messages are # printed and execution is terminated. # # Note that the verbose, debug, and quiet options can be set in this file. # It is a deliberate choice to ignore these for now. The assumption is that # the user will not be happy if we ignore the command line settings for a # while. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now"); # Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file"); # Temporarily disabled # Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); # Temporarily disabled # Temporarily disabled if ($rc_file_errors != 0) # Temporarily disabled { # Temporarily disabled $message = "fatal errors in file $rc_file_name encountered"; # Temporarily disabled gp_message ("debugXL", $subr_name, $message); # Temporarily disabled } # Temporarily disabled # Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file"); #------------------------------------------------------------------------------ # Get the ball rolling. Parse and interpret the options. Some first checks # are performed. # # Instead of bailing out on the first user error, we capture all errors, print # messages and then bail out. This is more user friendly. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Parse the user options"); $total_user_errors = 0; ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options ( \$#ARGV, \@ARGV); $total_user_errors += $option_errors; #------------------------------------------------------------------------------ # Dynamically load the modules needed. If a module is not available, print # an error message and bail out. # # This call replaces the following: # # use feature qw (state); # use List::Util qw (min max); # use Cwd; # use File::Basename; # use File::stat; # use POSIX; # use bignum; # # Note that this check cannot be done earlier, because in case of a missing # module, the man page would not be generated if the code ends prematurely # in case the --help and --version options are used.. #------------------------------------------------------------------------------ my ($module_errors_ref, $missing_modules_ref) = handle_module_availability (); my $module_errors = ${ $module_errors_ref }; if ($module_errors > 0) { my $msg; my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is"; my @missing_modules = @{ $missing_modules_ref }; for my $i (0 .. $#missing_modules) { $msg = "module $missing_modules[$i] is missing"; gp_message ("error", $subr_name, $msg); } $msg = $module_errors . " " . $plural_or_single . "missing - execution is terminated"; gp_message ("abort", $subr_name, $msg); } #------------------------------------------------------------------------------ # The user options have been taken in. Check for validity and consistency. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Process user options"); ($option_errors, $ignored_metrics_ref, $outputdir, $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref); @exp_dir_list = @{ $exp_dir_list_ref }; %ignored_metrics = %{$ignored_metrics_ref}; $total_user_errors += $option_errors; #------------------------------------------------------------------------------ # If no option is given for the output directory, pick a default. Otherwise, # if the output directory exists, wipe it clean in case the -O option is used. # If not, flag an error because the -o option does not overwrite an existing # directory. #------------------------------------------------------------------------------ if ($total_user_errors == 0) { ($option_errors, $outputdir) = set_up_output_directory (); $abs_path_outputdir = cwd () . "/" . $outputdir; $total_user_errors += $option_errors; } if ($total_user_errors == 0) { gp_message ("debug", $subr_name, "the output directory is $outputdir"); } else { #------------------------------------------------------------------------------ # All command line errors and warnings are printed here. #------------------------------------------------------------------------------ my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has"; $message = $g_error_keyword; $message .= $total_user_errors; if ($rc_file_errors > 0) { $message .= " additional"; } $message .= " fatal input $plural_or_single been detected:"; gp_message ("error", $subr_name, $message); for my $key (keys @g_user_input_errors) { gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]"); } } #------------------------------------------------------------------------------ # Bail out in case fatal errors have occurred. #------------------------------------------------------------------------------ if ( ($rc_file_errors + $total_user_errors) > 0) { my $msg = "the current values for the user controllable settings"; print_user_settings ("debug", $msg); gp_message ("abort", $subr_name, "execution terminated"); } else { my $msg = "after parsing the user options, the final values are"; print_user_settings ("debug", $msg); #------------------------------------------------------------------------------ # TBD: Enable once all planned features have been implemented and tested. #------------------------------------------------------------------------------ # Temporarily disabled $msg = "the final values for the user controllable settings"; # Temporarily disabled print_table_user_settings ("verbose", $msg); } #------------------------------------------------------------------------------ # Print a list with the experiment directory names #------------------------------------------------------------------------------ $pretty_dir_list = build_pretty_dir_list (\@exp_dir_list); my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is"; gp_message ("verbose", $subr_name, "The experiment " . $plural . ":"); gp_message ("verbose", $subr_name, $pretty_dir_list); #------------------------------------------------------------------------------ # Set up the first entry with the meta data for the experiments. This field # contains the absolute paths to the experiment directories. #------------------------------------------------------------------------------ for my $exp_dir (@exp_dir_list) { my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir); gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); gp_message ("debug", $subr_name, "filename = $filename"); gp_message ("debug", $subr_name, "directory_path = $directory_path"); $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path; } #------------------------------------------------------------------------------ # Check whether the experiment directories are valid. If not, it is a fatal # error. # Upon successful return, one directory has been selected to be used in the # remainder. This is not always the correct thing to do, but is the same as # the original code. In due time this should be addressed though. #------------------------------------------------------------------------------ ($dir_check_errors, $archive_dir_not_empty, $selected_archive, $elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref); if ($dir_check_errors) { gp_message ("abort", $subr_name, "execution terminated"); } else { gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid"); } %elf_rats = %{$elf_rats_ref}; #------------------------------------------------------------------------------- # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. This includes setting the base virtual address. #------------------------------------------------------------------------------- $ignore_value = determine_base_virtual_address ($exp_dir_list_ref); #------------------------------------------------------------------------------ # Check whether the experiment directories are consistent. #------------------------------------------------------------------------------ ($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref); if ($consistency_errors == 0) { gp_message ("verbose", $subr_name, "The experiment directories are consistent"); } else { gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors"); } #------------------------------------------------------------------------------ # The directories are consistent. We can now set the base virtual address of # the executable. #------------------------------------------------------------------------------ $base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; gp_message ("debug", $subr_name, "executable_name = $executable_name"); gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable"); #------------------------------------------------------------------------------ # The $GP_DISPLAY_TEXT tool is critical and has to be available in order # to proceed. # 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"); #------------------------------------------------------------------------------ # Check if $GP_DISPLAY_TEXT is executable for user, group, and other. # If not, print a warning only, since this may not be fatal but could # potentially lead to issues later on. #------------------------------------------------------------------------------ if (not is_file_executable ($GP_DISPLAY_TEXT)) { my $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and other"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Find out what the decimal separator is, as set by the user. #------------------------------------------------------------------------------ ($return_code, $decimal_separator, $convert_to_dot) = determine_decimal_separator (); if ($return_code == 0) { my $txt = "decimal separator is $decimal_separator " . "(conversion to dot is " . ($convert_to_dot == $TRUE ? "enabled" : "disabled").")"; gp_message ("debugXL", $subr_name, $txt); } else { my $msg = "the decimal separator cannot be determined - set to $decimal_separator"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Collect and store the system information. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Collect system information and adapt settings"); $return_code = get_system_config_info (); #------------------------------------------------------------------------------ # The 3 variables below are used in the remainder. # # The output from "uname -p" is recommended to be used for the ISA. #------------------------------------------------------------------------------ my $hostname_current = $local_system_config{hostname_current}; my $arch_uname_s = $local_system_config{kernel_name}; my $arch_uname = $local_system_config{processor}; gp_message ("debug", $subr_name, "set hostname_current = $hostname_current"); gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s"); gp_message ("debug", $subr_name, "set arch_uname = $arch_uname"); #------------------------------------------------------------------------------- # This function also sets the values in "g_arch_specific_settings". This # includes several definitions of regular expressions. #------------------------------------------------------------------------------- ($architecture_supported, $elf_arch, $elf_support) = set_system_specific_variables ($arch_uname, $arch_uname_s); gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported"); gp_message ("debug", $subr_name, "elf_arch = $elf_arch"); gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE")); for my $feature (sort keys %g_arch_specific_settings) { gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}"); } $arch = $g_arch_specific_settings{"arch"}; $subexp = $g_arch_specific_settings{"subexp"}; $linksubexp = $g_arch_specific_settings{"linksubexp"}; $g_locale_settings{"LANG"} = get_LANG_setting (); gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"); #------------------------------------------------------------------------------ # Temporarily reset selected settings since these are not yet implemented. #------------------------------------------------------------------------------ $ignore_value = reset_selected_settings (); #------------------------------------------------------------------------------ # TBD: Revisit. Is this really necessary? #------------------------------------------------------------------------------ ($executable_name, $va_executable_in_hex) = check_loadobjects_are_elf ($selected_archive); $elf_loadobjects_found = $TRUE; # TBD: Hack and those ARCHIVES_ names can be eliminated $ARCHIVES_MAP_NAME = $executable_name; $ARCHIVES_MAP_VADDR = $va_executable_in_hex; gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found"); $g_html_credits_line = ${ create_html_credits () }; gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line"); #------------------------------------------------------------------------------ # Add a "/" to simplify the construction of path names in the remainder. # # TBD: Push this into a subroutine(s). #------------------------------------------------------------------------------ $outputdir = append_forward_slash ($outputdir); gp_message ("debug", $subr_name, "prepared outputdir = $outputdir"); #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # ******* TBD: e.system not available on Linux!! #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ ## my $summary_metrics = 'e.totalcpu'; $detail_metrics = 'e.totalcpu'; $detail_metrics_system = 'e.totalcpu:e.system'; $call_metrics = 'a.totalcpu'; my $cmd_options; my $metrics_cmd; my $outfile1 = $outputdir ."metrics"; my $outfile2 = $outputdir . "metrictotals"; my $gp_error_file = $outputdir . $g_gp_error_logfile; #------------------------------------------------------------------------------ # Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is # to get all the output in files $outfile1 and $outfile2. These are then # parsed. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments"); $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file); if ($return_code != 0) { gp_message ("abort", $subr_name, "execution terminated"); } #------------------------------------------------------------------------------ # TBD: Test this code #------------------------------------------------------------------------------ open (METRICS, "<", $outfile1) or die ("$subr_name - unable to open metric value data file $outfile1 for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); chomp (@metrics_data = <METRICS>); close (METRICS); for my $i (keys @metrics_data) { gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]"); } #------------------------------------------------------------------------------ # Process the generated metrics data. #------------------------------------------------------------------------------ if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") #------------------------------------------------------------------------------ # The metrics will be derived from the experiments. #------------------------------------------------------------------------------ { gp_message ("verbose", $subr_name, "Process the metrics data"); ($metric_value_ref, $metric_description_ref, $metric_found_ref, $user_metrics, $system_metrics, $wall_metrics, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics ) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics); %metric_value = %{ $metric_value_ref }; %metric_description = %{ $metric_description_ref }; %metric_found = %{ $metric_found_ref }; %metric_description_reversed = reverse %metric_description; gp_message ("debugXL", $subr_name, "after the call to process_metrics_data"); for my $metric (sort keys %metric_value) { gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}"); } for my $metric (sort keys %metric_description) { gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}"); } gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics"); gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics"); gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics"); } else { #------------------------------------------------------------------------------ # A default set of metrics will be used. # # TBD: These should be OS dependent. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Select the set of default metrics"); ($metric_description_ref, $metric_found_ref, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics ) = set_default_metrics ($outfile1, \%ignored_metrics); %metric_description = %{ $metric_description_ref }; %metric_found = %{ $metric_found_ref }; %metric_description_reversed = reverse %metric_description; gp_message ("debug", $subr_name, "after the call to set_default_metrics"); } $number_of_metrics = split (":", $summary_metrics); gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics"); gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics"); gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system"); gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics"); gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics"); #------------------------------------------------------------------------------ # TBD Find a way to better handle this situation: #------------------------------------------------------------------------------ for my $im (keys %metric_found) { gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}"); } for my $im (keys %ignored_metrics) { if (not exists ($metric_found{$im})) { gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics"); } } #------------------------------------------------------------------------------ # Get the information on the experiments. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Generate the experiment information"); my $exp_info_file_ref; my $exp_info_file; my $exp_info_ref; my @exp_info; my $experiment_data_ref; $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); my @experiment_data = @{ $experiment_data_ref }; for my $i (sort keys @experiment_data) { my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . $experiment_data[$i]{"exp_name_full"}; gp_message ("debugM", $subr_name, $msg); } $experiment_data_ref = process_experiment_info ($experiment_data_ref); @experiment_data = @{ $experiment_data_ref }; for my $i (sort keys @experiment_data) { for my $fields (sort keys %{ $experiment_data[$i] }) { my $msg = "i = $i experiment_data[$i]{$fields} = " . $experiment_data[$i]{$fields}; gp_message ("debugXL", $subr_name, $msg); } } @g_html_experiment_stats = @{ create_exp_info ( \@exp_dir_list, \@experiment_data) }; $table_execution_stats_ref = html_generate_exp_summary ( \$outputdir, \@experiment_data); @table_execution_stats = @{ $table_execution_stats_ref }; #------------------------------------------------------------------------------ # Get the function overview. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Generate the list with functions executed"); my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); @sort_fields = @{$sort_fields_ref}; #------------------------------------------------------------------------------ # Parse the output from the fsummary command and store the relevant data for # all the functions listed there. #------------------------------------------------------------------------------ gp_message ("verbose", $subr_name, "Analyze and store the relevant function information"); ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref, $LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile); @function_info = @{ $function_info_ref }; %function_address_and_index = %{ $function_address_and_index_ref }; %addressobjtextm = %{ $addressobjtextm_ref }; %LINUX_vDSO = %{ $LINUX_vDSO_ref }; %function_view_structure = %{ $function_view_structure_ref }; for my $keys (0 .. $#function_info) { for my $fields (keys %{$function_info[$keys]}) { gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}"); } } for my $i (keys %addressobjtextm) { gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}"); } gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information"); $script_pc_metrics = generate_function_level_info (\@exp_dir_list, $call_metrics, $summary_metrics, $outputdir, $sort_fields_ref); gp_message ("verbose", $subr_name, "Preprocess the files with the function level information"); $ignore_value = preprocess_function_files ( $metric_description_ref, $script_pc_metrics, $outputdir, \@sort_fields); gp_message ("verbose", $subr_name, "For each function, generate a set of files"); ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files ( \@exp_dir_list, $executable_name, $time_percentage_multiplier, $summary_metrics, $process_all_functions, $elf_loadobjects_found, $outputdir, \@sort_fields, \@function_info, \%function_address_and_index, \%LINUX_vDSO, \%metric_description, $elf_arch, $base_va_executable, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats); @function_info = @{ $function_info_ref }; %function_address_info = %{ $function_address_info_ref }; %addressobj_index = %{ $addressobj_index_ref }; #------------------------------------------------------------------------------------- # Parse the disassembly information and generate the html files. #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files"); $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info, \%function_address_and_index, \$outputdir, \%addressobj_index); #------------------------------------------------------------------------------------- # Parse the source information and generate the html files. #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Parse the source files and generate the html files"); parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); #------------------------------------------------------------------------------------- # Parse the caller-callee information and generate the html files. #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file"); #------------------------------------------------------------------------------------- # Generate the caller-callee information. #------------------------------------------------------------------------------------- $ignore_value = generate_caller_callee ( \$number_of_metrics, \@function_info, \%function_view_structure, \%function_address_info, \%addressobjtextm, \$outputdir); #------------------------------------------------------------------------------------- # Parse the calltree information and generate the html files. #------------------------------------------------------------------------------------- if ($g_user_settings{"calltree"}{"current_value"} eq "on") { my $msg = "Process the call tree information and generate the html file"; gp_message ("verbose", $subr_name, $msg); $ignore_value = process_calltree ( \@function_info, \%function_address_info, \%addressobjtextm, $outputdir); } #------------------------------------------------------------------------------------- # TBD #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Generate the html file with the metrics information"); $ignore_value = process_metrics ( $outputdir, \@sort_fields, \%metric_description, \%ignored_metrics); #------------------------------------------------------------------------------------- # Generate the function view html files. #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Generate the function view html files"); $html_first_metric_file_ref = generate_function_view ( \$outputdir, \$summary_metrics, \$number_of_metrics, \@function_info, \%function_view_structure, \%function_address_info, \@sort_fields, \@exp_dir_list, \%addressobjtextm); $html_first_metric_file = ${ $html_first_metric_file_ref }; gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file"); my $html_test = ${ generate_home_link ("left") }; gp_message ("debugXL", $subr_name, "html_test = $html_test"); my $number_of_warnings_ref = create_html_warnings_page (\$outputdir); #------------------------------------------------------------------------------------- # Generate the index.html file. #------------------------------------------------------------------------------------- gp_message ("verbose", $subr_name, "Generate the index.html file"); $ignore_value = generate_index (\$outputdir, \$html_first_metric_file, \$summary_metrics, \$number_of_metrics, \@function_info, \%function_address_info, \@sort_fields, \@exp_dir_list, \%addressobjtextm, \%metric_description_reversed, $number_of_warnings_ref, \@table_execution_stats); #------------------------------------------------------------------------------------- # We're done. In debug mode, print the meta data for the experiment directories. #------------------------------------------------------------------------------------- $ignore_value = print_meta_data_experiments ("debug"); my $results_file = $abs_path_outputdir . "/index.html"; my $prologue_text = "Processing completed - view file $results_file in a browser"; gp_message ("diag", $subr_name, $prologue_text); return (0); } #-- End of subroutine main #------------------------------------------------------------------------------ # Print a message after a failure in $GP_DISPLAY_TEXT. #------------------------------------------------------------------------------ sub msg_display_text_failure { my $subr_name = get_my_name (); my ($gp_display_text_cmd, $error_code, $error_file) = @_; my $msg; $msg = "error code = $error_code - failure executing the following command:"; gp_message ("error", $subr_name, $msg); gp_message ("error", $subr_name, $gp_display_text_cmd); $msg = "check file $error_file for more details"; gp_message ("error", $subr_name, $msg); return (0); } #-- End of subroutine msg_display_text_failure #------------------------------------------------------------------------------ # If it is not present, add a "/" to the name of the argument. This is # intended to be used for the name of the output directory and makes it # easier to construct pathnames. #------------------------------------------------------------------------------ sub append_forward_slash { my $subr_name = get_my_name (); my ($input_string) = @_; my $length_of_string = length ($input_string); my $return_string = $input_string; if (rindex ($input_string, "/") != $length_of_string-1) { $return_string .= "/"; } return ($return_string); } #-- End of subroutine append_forward_slash #------------------------------------------------------------------------------ # Return a string with a comma separated list of directory names. #------------------------------------------------------------------------------ sub build_pretty_dir_list { my $subr_name = get_my_name (); my ($dir_list_ref) = @_; my @dir_list = @{ $dir_list_ref}; my $pretty_dir_list = join ("\n", @dir_list); return ($pretty_dir_list); } #-- End of subroutine build_pretty_dir_list #------------------------------------------------------------------------------ # Calculate the target address in hex by adding the instruction to the # instruction address. #------------------------------------------------------------------------------ sub calculate_target_hex_address { my $subr_name = get_my_name (); my ($instruction_address, $instruction_offset) = @_; my $dec_branch_target; my $d1; my $d2; my $first_char; my $length_of_string; my $mask; my $number_of_fields; my $raw_hex_branch_target; my $result; if ($g_addressing_mode eq "64 bit") { $mask = "0xffffffffffffffff"; $number_of_fields = 16; } else { gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n"); } $length_of_string = length ($instruction_offset); $first_char = lcfirst (substr ($instruction_offset,0,1)); $d1 = bigint::hex ($instruction_offset); $d2 = bigint::hex ($mask); # if ($first_char eq "f") if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields)) { #------------------------------------------------------------------------------ # The offset is negative. Convert to decimal and perform the subtrraction. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # XOR the decimal representation and add 1 to the result. #------------------------------------------------------------------------------ $result = ($d1 ^ $d2) + 1; $dec_branch_target = bigint::hex ($instruction_address) - $result; } else { $result = $d1; $dec_branch_target = bigint::hex ($instruction_address) + $result; } #------------------------------------------------------------------------------ # Convert to hexadecimal. #------------------------------------------------------------------------------ $raw_hex_branch_target = sprintf ("%x", $dec_branch_target); return ($raw_hex_branch_target); } #-- End of subroutine calculate_target_hex_address #------------------------------------------------------------------------------ # Sets the absolute path to all commands in array @cmds. The commands and # their respective paths are stored in hash "g_mapped_cmds". # # 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. #------------------------------------------------------------------------------ sub check_and_define_cmds { my $subr_name = get_my_name (); my ($cmds_ref, $search_path_ref) = @_; #------------------------------------------------------------------------------ # Dereference the array addressess first and then store the contents. #------------------------------------------------------------------------------ my @cmds = @{$cmds_ref}; my @search_path = @{$search_path_ref}; my $found_match; my $target_cmd; my $failed_cmd; my $no_of_failed_mappings; my $failed_cmds; gp_message ("debug", $subr_name, "\@cmds = @cmds"); gp_message ("debug", $subr_name, "\@search_path = @search_path"); #------------------------------------------------------------------------------ # Search for the command to be in the search path given. In case no such path # can be found, the entry in $g_mapped_cmds is assigned a special value that # will be checked for in the next block. #------------------------------------------------------------------------------ for my $cmd (@cmds) { $found_match = $FALSE; for my $path (@search_path) { $target_cmd = $path . "/" . $cmd; if (-x $target_cmd) { $found_match = $TRUE; $g_mapped_cmds{$cmd} = $target_cmd; last; } } if (not $found_match) { $g_mapped_cmds{$cmd} = "road_to_nowhere"; } } #------------------------------------------------------------------------------ # Scan the results stored in $g_mapped_cmds and flag errors. #------------------------------------------------------------------------------ $no_of_failed_mappings = 0; $failed_cmds = ""; while ( my ($cmd, $mapped) = each %g_mapped_cmds) { if ($mapped eq "road_to_nowhere") { my $msg = "cannot find a path for command $cmd - " . "assume this will still work without a path"; gp_message ("warning", $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"); } } 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"); } return ($no_of_failed_mappings); } #-- End of subroutine check_and_define_cmds #------------------------------------------------------------------------------ # Look for a branch instruction, or the special endbr32/endbr64 instruction # that is also considered to be a branch target. Note that the latter is x86 # specific. #------------------------------------------------------------------------------ sub check_and_proc_dis_branches { my $subr_name = get_my_name (); my ($input_line_ref, $line_no_ref, $branch_target_ref, $extended_branch_target_ref, $branch_target_no_ref_ref) = @_; my $input_line = ${ $input_line_ref }; my $line_no = ${ $line_no_ref }; my %branch_target = %{ $branch_target_ref }; my %extended_branch_target = %{ $extended_branch_target_ref }; my %branch_target_no_ref = %{ $branch_target_no_ref_ref }; my $found_it = $TRUE; my $hex_branch_target; my $instruction_address; my $instruction_offset; my $msg; my $raw_hex_branch_target; if ( ($input_line =~ /$g_branch_regex/) or ($input_line =~ /$g_endbr_regex/)) { if (defined ($3)) { $msg = "found a branch or endbr instruction: " . "\$1 = $1 \$2 = $2 \$3 = $3"; } else { $msg = "found a branch or endbr instruction: " . "\$1 = $1 \$2 = $2"; } gp_message ("debugXL", $subr_name, $msg); if (defined ($1)) { #------------------------------------------------------------------------------ # Found a qualifying instruction #------------------------------------------------------------------------------ $instruction_address = $1; if (defined ($3)) { #------------------------------------------------------------------------------ # This must be the branch target and needs to be converted and processed. #------------------------------------------------------------------------------ $instruction_offset = $3; $raw_hex_branch_target = calculate_target_hex_address ( $instruction_address, $instruction_offset); $hex_branch_target = "0x" . $raw_hex_branch_target; $branch_target{$hex_branch_target} = 1; $extended_branch_target{$instruction_address} = $raw_hex_branch_target; } if (defined ($2) and (not defined ($3))) { #------------------------------------------------------------------------------ # Unlike a branch, the endbr32/endbr64 instructions do not have a second field. #------------------------------------------------------------------------------ my $instruction_name = $2; if ($instruction_name =~ /$g_endbr_inst_regex/) { my $msg = "found endbr: $instruction_name " . $instruction_address; gp_message ("debugXL", $subr_name, $msg); $raw_hex_branch_target = $instruction_address; $hex_branch_target = "0x" . $raw_hex_branch_target; $branch_target_no_ref{$instruction_address} = 1; } } } else { #------------------------------------------------------------------------------ # TBD: Perhaps this should be an assertion or alike. #------------------------------------------------------------------------------ $branch_target{"0x0000"} = $FALSE; gp_message ("debug", $subr_name, "cannot determine branch target"); } } else { $found_it = $FALSE; } return (\$found_it, \%branch_target, \%extended_branch_target, \%branch_target_no_ref); } #-- End of subroutine check_and_proc_dis_branches #------------------------------------------------------------------------------ # Check an input line from the disassembly file to include a function call. # If it does, process the line and return the branch target results. #------------------------------------------------------------------------------ sub check_and_proc_dis_func_call { my $subr_name = get_my_name (); my ($input_line_ref, $line_no_ref, $branch_target_ref, $extended_branch_target_ref) = @_; my $input_line = ${ $input_line_ref }; my $line_no = ${ $line_no_ref }; my %branch_target = %{ $branch_target_ref }; my %extended_branch_target = %{ $extended_branch_target_ref }; my $found_it = $TRUE; my $hex_branch_target; my $instruction_address; my $instruction_offset; my $msg; my $raw_hex_branch_target; if ( $input_line =~ /$g_function_call_v2_regex/ ) { $msg = "found a function call - line[$line_no] = $input_line"; gp_message ("debugXL", $subr_name, $msg); if (not defined ($2)) { $msg = "line[$line_no] " . "an instruction address is expected, but not found"; gp_message ("assertion", $subr_name, $msg); } else { $instruction_address = $2; $msg = "instruction_address = $instruction_address"; gp_message ("debugXL", $subr_name, $msg); if (not defined ($4)) { $msg = "line[$line_no] " . "an address offset is expected, but not found"; gp_message ("assertion", $subr_name, $msg); } else { $instruction_offset = $4; if ($instruction_offset =~ /[0-9a-fA-F]+/) { $msg = "calculate branch target: " . "instruction_address = $instruction_address"; gp_message ("debugXL", $subr_name, $msg); $msg = "calculate branch target: " . "instruction_offset = $instruction_offset"; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # The instruction offset needs to be converted and added to the instruction # address. #------------------------------------------------------------------------------ $raw_hex_branch_target = calculate_target_hex_address ( $instruction_address, $instruction_offset); $hex_branch_target = "0x" . $raw_hex_branch_target; $msg = "calculated hex_branch_target = " . $hex_branch_target; gp_message ("debugXL", $subr_name, $msg); $branch_target{$hex_branch_target} = 1; $extended_branch_target{$instruction_address} = $raw_hex_branch_target; $msg = "set branch_target{$hex_branch_target} to 1"; gp_message ("debugXL", $subr_name, $msg); $msg = "added extended_branch_target{$instruction_address}" . " = $extended_branch_target{$instruction_address}"; gp_message ("debugXL", $subr_name, $msg); } else { $msg = "line[$line_no] unknown address format"; gp_message ("assertion", $subr_name, $msg); } } } } else { $found_it = $FALSE; } return (\$found_it, \%branch_target, \%extended_branch_target); } #-- End of subroutine check_and_proc_dis_func_call #------------------------------------------------------------------------------ # Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool # needed to provide the information. If it can not be found, execution is # terminated. # # We first search foe this tool in the current execution directory. If it # cannot be found there, use $PATH to try to locate it. #------------------------------------------------------------------------------ sub check_availability_tool { my $subr_name = get_my_name (); my ($location_gp_command_ref) = @_; my $error_code; my $error_occurred; my $msg; my $output_which_gp_display_text; my $return_value; my $target_cmd; #------------------------------------------------------------------------------ # 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}; $return_value = ${ $return_value_ref}; $msg = "error_occurred = $error_occurred return_value = $return_value"; gp_message ("debugXL", $subr_name, $msg); if (not $error_occurred) #------------------------------------------------------------------------------ # All is well and gp-display-text has been located. #------------------------------------------------------------------------------ { $g_path_to_tools = $return_value; $msg = "located $GP_DISPLAY_TEXT in execution directory"; gp_message ("debug", $subr_name, $msg); $msg = "g_path_to_tools = $g_path_to_tools"; gp_message ("debug", $subr_name, $msg); } else #------------------------------------------------------------------------------ # Something went wrong, but perhaps we can still continue. Try to find # $GP_DISPLAY_TEXT through the search path. #------------------------------------------------------------------------------ { $msg = "error accessing $GP_DISPLAY_TEXT: $return_value - " . "run time behaviour may be undefined"; 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"; gp_message ("debug", $subr_name, $msg); $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; ($error_code, $output_which_gp_display_text) = execute_system_cmd ($target_cmd); if ($error_code == 0) { my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($output_which_gp_display_text); $g_path_to_tools = $gp_path; $msg = "using $GP_DISPLAY_TEXT in $g_path_to_tools instead"; 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); $msg = "fatal error executing command $target_cmd"; gp_message ("abort", $subr_name, $msg); } } return (\$g_path_to_tools); } #-- End of subroutine check_availability_tool #------------------------------------------------------------------------------ # This function determines whether load objects are in ELF format. # # Compared to the original code, any input value other than 2 or 3 is rejected # upfront. This not only reduces the nesting level, but also eliminates a # possible bug. # # Also, by isolating the tests for the input files, another nesting level could # be eliminated, further simplifying this still too complex code. #------------------------------------------------------------------------------ sub check_loadobjects_are_elf { my $subr_name = get_my_name (); my ($selected_archive) = @_; my $hostname_current = $local_system_config{"hostname_current"}; my $arch = $local_system_config{"processor"}; my $arch_uname_s = $local_system_config{"kernel_name"}; my $extracted_information; my $elf_magic_number; my $executable_name; my $va_executable_in_hex; my $arch_exp; my $hostname_exp; my $os_exp; my $os_exp_full; my $archives_file; my $rc_b; my $file; my $line; my $name; my $name_path; my $foffset; my $vaddr; my $modes; my $path_to_map_file; my $path_to_log_file; #------------------------------------------------------------------------------ # TBD: Parameterize and should be the first experiment directory from the list. #------------------------------------------------------------------------------ $path_to_log_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; $path_to_log_file .= $selected_archive; $path_to_log_file .= "/log.xml"; gp_message ("debug", $subr_name, "hostname_current = $hostname_current"); gp_message ("debug", $subr_name, "arch = $arch"); gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); #------------------------------------------------------------------------------ # TBD # # This check can probably be removed since the presence of the log.xml file is # checked for in an earlier phase. #------------------------------------------------------------------------------ open (LOG_XML, "<", $path_to_log_file) or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading"); while (<LOG_XML>) { $line = $_; chomp ($line); gp_message ("debug", $subr_name, "read line: $line"); #------------------------------------------------------------------------------ # Search for the first line starting with "<system". Bail out if found and # parsed. These are two examples: # <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> # <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968"> #------------------------------------------------------------------------------ if ($line =~ /^\s*<system\s+/) { gp_message ("debug", $subr_name, "selected the following line from the log.xml file:"); gp_message ("debug", $subr_name, "$line"); if ($line =~ /.*\s+hostname="([^"]+)/) { $hostname_exp = $1; gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp"); } if ($line =~ /.*\s+arch="([^"]+)/) { $arch_exp = $1; gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp"); } if ($line =~ /.*\s+os="([^"]+)/) { $os_exp_full = $1; #------------------------------------------------------------------------------ # Capture the first word only. #------------------------------------------------------------------------------ if ($os_exp_full =~ /([^\s]+)/) { $os_exp = $1; } gp_message ("debug", $subr_name, "extracted os_exp = $os_exp"); } last; } } #-- End of while loop close (LOG_XML); #------------------------------------------------------------------------------ # If the current system is identical to the system used in the experiment, # we can return early. Otherwise we need to dig deeper. # # TBD: How about the other experiment directories?! This needs to be fixed. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "completed while loop"); gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp"); gp_message ("debug", $subr_name, "arch_exp = $arch_exp"); gp_message ("debug", $subr_name, "os_exp = $os_exp"); #TBD: THIS DOES NOT CHECK IF ELF IS FOUND! if (($hostname_current eq $hostname_exp) and ($arch eq $arch_exp) and ($arch_uname_s eq $os_exp)) { gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system"); gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE"); # FAKE return ($TRUE); } if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) { gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) { gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}"); } } #------------------------------------------------------------------------------ # Check if the selected experiment directory has archived files in ELF format. # If not, use the information in map.xml to get the name of the executable # and the virtual address. #------------------------------------------------------------------------------ if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) { gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format"); gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML"); ## return ($TRUE); } gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format"); $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; $path_to_map_file .= $selected_archive; $path_to_map_file .= "/map.xml"; open (MAP_XML, "<", $path_to_map_file) or die ($subr_name, "unable to open file $path_to_map_file for reading: $!"); gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading"); #------------------------------------------------------------------------------ # Scan the map.xml file. We need to find the name of the executable with the # mode set to 0x005. For this entry we have to capture the virtual address. #------------------------------------------------------------------------------ $extracted_information = $FALSE; while (<MAP_XML>) { $line = $_; chomp ($line); gp_message ("debug", $subr_name, "MAP_XML read line = $line"); ## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) { gp_message ("debug", $subr_name, "target line = $line"); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); # $error_extracting_information = $TRUE; $executable_name = $name; my $result_VA = 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"); if ($modes eq "005") { $extracted_information = $TRUE; last; } } } if (not $extracted_information) { my $msg = "cannot find the necessary information in the $path_to_map_file file"; gp_message ("assertion", $subr_name, $msg); } ## $executable_name = $ARCHIVES_MAP_NAME; ## $va_executable_in_hex = $ARCHIVES_MAP_VADDR; return ($executable_name, $va_executable_in_hex); } #-- End of subroutine check_loadobjects_are_elf #------------------------------------------------------------------------------ # Compare the current metric values against the maximum values. Mark the line # if a value is within the percentage defined by $hp_value. #------------------------------------------------------------------------------ sub check_metric_values { my $subr_name = get_my_name (); my ($metric_values, $max_metric_values_ref) = @_; my @max_metric_values = @{ $max_metric_values_ref }; my @current_metrics = (); my $colour_coded_line; my $current_value; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; my $max_value; my $relative_distance; @current_metrics = split (" ", $metric_values); $colour_coded_line = $FALSE; for my $metric (0 .. $#current_metrics) { $current_value = $current_metrics[$metric]; if (exists ($max_metric_values[$metric])) { $max_value = $max_metric_values[$metric]; gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) { # TBD: abs needed? gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); if ($relative_distance >= $hp_value/100.0) { gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); $colour_coded_line = $TRUE; last; } } } } #-- End of loop over metrics return (\$colour_coded_line); } #-- End of subroutine check_metric_values #------------------------------------------------------------------------------ # Check if the system is supported. #------------------------------------------------------------------------------ sub check_support_for_processor { my $subr_name = get_my_name (); my ($machine_ref) = @_; my $machine = ${ $machine_ref }; my $is_supported; if ($machine eq "x86_64") { $is_supported = $TRUE; } else { $is_supported = $FALSE; } return (\$is_supported); } #-- End of subroutine check_support_for_processor #------------------------------------------------------------------------------ # Check if the value for the user option given is valid. # # In case the value is valid, the g_user_settings table is updated. # Otherwise an error message is printed. # # The return value is TRUE/FALSE. #------------------------------------------------------------------------------ sub check_user_option { my $subr_name = get_my_name (); my ($internal_option_name, $value) = @_; my $message; my $return_value; my $option = $g_user_settings{$internal_option_name}{"option"}; my $data_type = $g_user_settings{$internal_option_name}{"data_type"}; my $no_of_arguments = $g_user_settings{$internal_option_name}{"no_of_arguments"}; if (($no_of_arguments >= 1) and ((not defined ($value)) or (length ($value) == 0))) { #------------------------------------------------------------------------------ # If there was no value given, but it is required, flag an error. # There could also be a value, but it might be the empty string. # # Note that that there are currently no options with multiple values. Should # these be introduced, the current check may need to be refined. #------------------------------------------------------------------------------ $message = "the $option option requires a value"; push (@g_user_input_errors, $message); $return_value = $FALSE; } elsif ($no_of_arguments >= 1) { #------------------------------------------------------------------------------ # There is an input value. Check if it is valid and if so, store it. # # Note that we allow the options to be case insensitive. #------------------------------------------------------------------------------ my $valid = verify_if_input_is_valid ($value, $data_type); if ($valid) { if (($data_type eq "onoff") or ($data_type eq "size")) { $g_user_settings{$internal_option_name}{"current_value"} = lc ($value); } else { $g_user_settings{$internal_option_name}{"current_value"} = $value; } $g_user_settings{$internal_option_name}{"defined"} = $TRUE; $return_value = $TRUE; } else { $message = "incorrect value for $option option: $value"; push (@g_user_input_errors, $message); $return_value = $FALSE; } } return ($return_value); } #-- End of subroutine check_user_option #------------------------------------------------------------------------------- # This subroutine performs multiple checks on the experiment directories. One # or more failures are fatal. #------------------------------------------------------------------------------- sub check_validity_exp_dirs { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my %elf_rats = (); my $dir_not_found = $FALSE; my $invalid_dir = $FALSE; my $dir_check_errors = $FALSE; my $missing_dirs = 0; my $invalid_dirs = 0; my $archive_dir_not_empty; my $elf_magic_number; my $archives_file; my $archives_dir; my $first_line; my $count_exp_dir_not_elf; my $first_time; my $filename; my $comment; my $selected_archive_has_elf_format; my $selected_archive; my $archive_dir_selected; my $no_of_files_in_selected_archive; #------------------------------------------------------------------------------- # Check if the experiment directories exist and are valid. #------------------------------------------------------------------------------- for my $exp_dir (@exp_dir_list) { if (not -d $exp_dir) { $dir_not_found = $TRUE; $missing_dirs++; gp_message ("error", $subr_name, "directory $exp_dir not found"); $dir_check_errors = $TRUE; } else { #------------------------------------------------------------------------------- # Files log.xml and map.xml have to be there. #------------------------------------------------------------------------------- gp_message ("debug", $subr_name, "directory $exp_dir found"); if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) { gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory"); } else { $invalid_dir = $TRUE; $invalid_dirs++; gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing"); gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory"); $dir_check_errors = $TRUE; } } } if ($dir_not_found) { gp_message ("error", $subr_name, "a total of $missing_dirs directories not found"); } if ($invalid_dir) { gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid"); } #------------------------------------------------------------------------------- # Initialize ELF status to FALSE. #------------------------------------------------------------------------------- ## for my $exp_dir (@exp_dir_list) for my $exp_dir (keys %g_exp_dir_meta_data) { $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; } #------------------------------------------------------------------------------- # Check if the load objects are in ELF format. #------------------------------------------------------------------------------- for my $exp_dir (keys %g_exp_dir_meta_data) { $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; $archive_dir_not_empty = $FALSE; $first_time = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); gp_message ("debug", $subr_name, "checking $archives_dir"); while (glob ("$archives_dir/*")) { $filename = get_basename ($_); gp_message ("debug", $subr_name, "processing file: $filename"); $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; $archive_dir_not_empty = $TRUE; #------------------------------------------------------------------------------- # Replaces the ELF_RATS part in elf_phdr. # # Challenge: splittable_mrg.c_I0txnOW_Wn5 # # TBD: Store this for each relevant experiment directory. #------------------------------------------------------------------------------- my $last_dot = rindex ($filename,"."); my $underscore_before_dot = $TRUE; my $first_underscore = -1; gp_message ("debugXL", $subr_name, "last_dot = $last_dot"); while ($underscore_before_dot) { $first_underscore = index ($filename, "_", $first_underscore+1); if ($last_dot < $first_underscore) { $underscore_before_dot = $FALSE; } } my $original_name = substr ($filename, 0, $first_underscore); gp_message ("debug", $subr_name, "stripped archive name: $original_name"); if (not exists ($elf_rats{$original_name})) { $elf_rats{$original_name} = [$filename, $exp_dir]; } #------------------------------------------------------------------------------- # We only need to detect the presence of an object once. #------------------------------------------------------------------------------- if ($first_time) { $first_time = $FALSE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); } } } #-- End of loop over experiment directories for my $exp_dir (sort keys %g_exp_dir_meta_data) { my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty")); } #------------------------------------------------------------------------------ # Verify that all relevant files in the archive directories are in ELF format. #------------------------------------------------------------------------------ for my $exp_dir (sort keys %g_exp_dir_meta_data) { $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir"); #------------------------------------------------------------------------------ # Check if any of the loadobjects is of type ELF. Bail out on the first one # found. The assumption is that all other loadobjects must be of type ELF too # then. #------------------------------------------------------------------------------ for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives/" . $aname; open (ARCF,"<", $filename) or die ("unable to open file $filename for reading - '$!'"); $first_line = <ARCF>; close (ARCF); #------------------------------------------------------------------------------ # The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF). # # See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format #------------------------------------------------------------------------------ # if ($first_line =~ /^\177ELF.*/) $elf_magic_number = unpack ('H8', $first_line); # gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number"); if ($elf_magic_number eq "7f454c46") { $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE; last; } } } } for my $exp_dir (sort keys %g_exp_dir_meta_data) { $comment = "the loadobjects in the archive in $exp_dir are "; $comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in "; $comment .= "ELF format"; gp_message ("debug", $subr_name, $comment); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { gp_message ("debug", $subr_name, "there are no archived files in $exp_dir"); } } #------------------------------------------------------------------------------ # If there are archived files and they are not in ELF format, a debug is # issued. # # TBD: Bail out? #------------------------------------------------------------------------------ $count_exp_dir_not_elf = 0; for my $exp_dir (sort keys %g_exp_dir_meta_data) { if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) { $count_exp_dir_not_elf++; } } if ($count_exp_dir_not_elf != 0) { gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects"); } #------------------------------------------------------------------------------ # Select the experiment directory that is used for the files in the archive. # By default, a directory with archived files is used, but in case this does # not exist, a directory without archived files is selected. Obviously this # needs to be dealt with later on. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Try the experiments with archived files first. #------------------------------------------------------------------------------ $archive_dir_not_empty = $FALSE; $archive_dir_selected = $FALSE; ## for my $exp_dir (sort @exp_dir_list) for my $exp_dir (sort keys %g_exp_dir_meta_data) { gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir"); gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $selected_archive = $exp_dir; $archive_dir_not_empty = $TRUE; $archive_dir_selected = $TRUE; $selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE; last; } } if (not $archive_dir_selected) #------------------------------------------------------------------------------ # None are found and pick the first one without archived files. #------------------------------------------------------------------------------ { for my $exp_dir (sort keys %g_exp_dir_meta_data) { if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $selected_archive = $exp_dir; $archive_dir_not_empty = $FALSE; $archive_dir_selected = $TRUE; $selected_archive_has_elf_format = $FALSE; last; } } } gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis"); gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty")); gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format"); #------------------------------------------------------------------------------ # Get the size of the hash that contains the archived files. #------------------------------------------------------------------------------ ## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive"); for my $exp_dir (sort keys %g_exp_dir_meta_data) { my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty")); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}"); } } } return ($dir_check_errors, $archive_dir_not_empty, $selected_archive, \%elf_rats); } #-- End of subroutine check_validity_exp_dirs #------------------------------------------------------------------------------ # Color the string and optionally mark it boldface. # # For supported colors, see: # https://www.w3schools.com/colors/colors_names.asp #------------------------------------------------------------------------------ sub color_string { my $subr_name = get_my_name (); my ($input_string, $boldface, $color) = @_; my $colored_string; $colored_string = "<font color='" . $color . "'>"; if ($boldface) { $colored_string .= "<b>"; } $colored_string .= $input_string; if ($boldface) { $colored_string .= "</b>"; } $colored_string .= "</font>"; return ($colored_string); } #-- End of subroutine color_string #------------------------------------------------------------------------------ # Generate the array with the info on the experiment(s). #------------------------------------------------------------------------------ sub create_exp_info { my $subr_name = get_my_name (); my ($experiment_dir_list_ref, $experiment_data_ref) = @_; my @experiment_dir_list = @{ $experiment_dir_list_ref }; my @experiment_data = @{ $experiment_data_ref }; my @experiment_stats_html = (); my $experiment_stats_line; my $plural; $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; $experiment_stats_line = "<h3>\n"; $experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n"; $experiment_stats_line .= "</h3>\n"; $experiment_stats_line .= "<pre>\n"; for my $i (0 .. $#experiment_dir_list) { $experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n"; } $experiment_stats_line .= "</pre>\n"; push (@experiment_stats_html, $experiment_stats_line); gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --"); return (\@experiment_stats_html); } #-- End of subroutine create_exp_info #------------------------------------------------------------------------------ # Trivial function to generate a tag. This has been made a function to ensure # consistency creating tags and also make it easier to change them. #------------------------------------------------------------------------------ sub create_function_tag { my $subr_name = get_my_name (); my ($tag_id) = @_; my $function_tag = "function_tag_" . $tag_id; return ($function_tag); } #-- End of subroutine create_function_tag #------------------------------------------------------------------------------ # Generate and return a string with the credits. Note that this also ends # the HTML formatting controls. #------------------------------------------------------------------------------ sub create_html_credits { my $subr_name = get_my_name (); my $msg; my $the_date; my @months = qw (January February March April May June July August September October November December); my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime (); $year += 1900; $the_date = $months[$mon] . " " . $mday . ", " . $year; $msg = "<i>\n"; $msg .= "Output generated by the $driver_cmd command "; $msg .= "on $the_date "; $msg .= "(GNU binutils version " . $binutils_version . ")"; $msg .= "\n"; $msg .= "</i>"; gp_message ("debug", $subr_name, "the date = $the_date"); return (\$msg); } #-- End of subroutine create_html_credits #------------------------------------------------------------------------------ # Generate a string that contains all the necessary HTML header information, # plus a title. # # See also https://www.w3schools.com for the details on the features used. #------------------------------------------------------------------------------ sub create_html_header { my $subr_name = get_my_name (); my ($title_ref) = @_; my $title = ${ $title_ref }; my $LANG = $g_locale_settings{"LANG"}; my $background_color = $g_html_color_scheme{"background_color_page"}; my $html_header; $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n"; $html_header .= "<html lang=\"$LANG\">\n"; $html_header .= "<head>\n"; $html_header .= "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n"; $html_header .= "<title>" . $title . "</title>\n"; $html_header .= "</head>\n"; $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; $html_header .= "<style>\n"; $html_header .= "div.left {\n"; $html_header .= "text-align: left;\n"; $html_header .= "}\n"; $html_header .= "div.right {\n"; $html_header .= "text-align: right;\n"; $html_header .= "}\n"; $html_header .= "div.center {\n"; $html_header .= "text-align: center;\n"; $html_header .= "}\n"; $html_header .= "div.justify {\n"; $html_header .= "text-align: justify;\n"; $html_header .= "}\n"; $html_header .= "</style>"; return (\$html_header); } #-- End of subroutine create_html_header #------------------------------------------------------------------------------ # Create an HTML page with the warnings. If there are no warnings, include # line to this extent. The alternative is to supporess the entire page, but # that breaks the consistency in the output. #------------------------------------------------------------------------------ sub create_html_warnings_page { my $subr_name = get_my_name (); my ($outputdir_ref) = @_; my $outputdir = ${ $outputdir_ref }; my $file_title; my $html_acknowledgement; my $html_end; my $html_header; my $html_home_left; my $html_home_right; my $html_title_header; my $msg_no_warnings = "There are no warning messages issued."; my $page_title; my $position_text; my $size_text; my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html"; gp_message ("debug", $subr_name, "outfile = $outfile"); open (WARNINGS_OUT, ">", $outfile) or die ("unable to open $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); gp_message ("debug", $subr_name, "building warning file $outfile"); #------------------------------------------------------------------------------ # Get the number of warnings and in debug mode, print the list. #------------------------------------------------------------------------------ my $number_of_warnings = scalar (@g_warning_messages); gp_message ("debug", $subr_name, "number_of_warnings = $number_of_warnings"); if ($number_of_warnings > 0) { for my $i (0 .. $#g_warning_messages) { print "$g_warning_messages[$i]\n"; my $msg = "g_warning_messages[$i] = $g_warning_messages[$i]"; gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Generate some of the structures used in the HTML output. #------------------------------------------------------------------------------ $file_title = "Warning messages"; $html_header = ${ create_html_header (\$file_title) }; $html_home_right = ${ generate_home_link ("right") }; $page_title = "Warning Messages"; $size_text = "h2"; $position_text = "center"; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; #------------------------------------------------------------------------------- # Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------- $html_home_left = ${ generate_home_link ("left") }; $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; #------------------------------------------------------------------------------- # Generate the HTML file. #------------------------------------------------------------------------------- print WARNINGS_OUT $html_header; print WARNINGS_OUT $html_home_right; print WARNINGS_OUT $html_title_header; if ($number_of_warnings > 0) { print WARNINGS_OUT "<pre>\n"; print WARNINGS_OUT "$_\n" for @g_warning_messages; print WARNINGS_OUT "</pre>\n"; } else { print WARNINGS_OUT $msg_no_warnings; } print WARNINGS_OUT $html_home_left; print WARNINGS_OUT "<br>\n"; print WARNINGS_OUT $html_acknowledgement; print WARNINGS_OUT $html_end; close (WARNINGS_OUT); return (\$number_of_warnings); } #-- End of subroutine create_html_warnings_page #------------------------------------------------------------------------------- # Create a complete table. #------------------------------------------------------------------------------- sub create_table { my $subr_name = get_my_name (); my ($experiment_data_ref, $table_definition_ref) = @_; my @experiment_data = @{ $experiment_data_ref }; my @table_definition = @{ $table_definition_ref }; my @html_exp_table_data = (); my $html_header_line; my $html_table_line; my $html_end_table; $html_header_line = ${ create_table_header_exp (\@experiment_data) }; push (@html_exp_table_data, $html_header_line); for my $i (sort keys @table_definition) { $html_table_line = ${ create_table_entry_exp (\$table_definition[$i]{"name"}, \$table_definition[$i]{"key"}, \@experiment_data) }; push (@html_exp_table_data, $html_table_line); my $msg = "i = $i html_table_line = $html_table_line"; gp_message ("debugXL", $subr_name, $msg); } $html_end_table = "</table>\n"; push (@html_exp_table_data, $html_end_table); return (\@html_exp_table_data); } #-- End of subroutine create_table #------------------------------------------------------------------------------- # Create one row for the table with experiment info. #------------------------------------------------------------------------------- sub create_table_entry_exp { my $subr_name = get_my_name (); my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_; my $entry_name = ${ $entry_name_ref }; my $key = ${ $key_ref }; my @experiment_data = @{ $experiment_data_ref }; gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key"); my $html_line; $html_line = "<tr><div class=\"left\"><td><b> "; $html_line = "<tr><div class=\"right\"><td><b> "; $html_line .= $entry_name; $html_line .= " </b></td>"; for my $i (sort keys @experiment_data) { if (exists ($experiment_data[$i]{$key})) { $html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>"; } else { ## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist"); gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist"); } } $html_line .= "</div></tr>\n"; gp_message ("debugXL", $subr_name, "return html_line = $html_line"); return (\$html_line); } #-- End of subroutine create_table_entry_exp #------------------------------------------------------------------------------- # Create the table header for the experiment info. #------------------------------------------------------------------------------- sub create_table_header_exp { my $subr_name = get_my_name (); my ($experiment_data_ref) = @_; my @experiment_data = @{ $experiment_data_ref }; my $html_header_line; $html_header_line = "<style>\n"; $html_header_line .= "table, th, td {\n"; $html_header_line .= "border: 1px solid black;\n"; $html_header_line .= "border-collapse: collapse;\n"; $html_header_line .= "}\n"; $html_header_line .= "</style>\n"; $html_header_line .= "</pre>\n"; $html_header_line .= "<table>\n"; $html_header_line .= "<tr><div class=\"center\"><th></th>"; for my $i (sort keys @experiment_data) { $html_header_line .= "<th> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>"; } $html_header_line .= "</div></tr>\n"; gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line"); return (\$html_header_line); } #-- End of subroutine create_table_header_exp #------------------------------------------------------------------------------- # Handle where the output should go. If needed, a directory is created where # the results will go. #------------------------------------------------------------------------------- sub define_the_output_directory { my $subr_name = get_my_name (); my ($define_new_output_dir, $overwrite_output_dir) = @_; my $outputdir; #------------------------------------------------------------------------------- # If neither -o or -O are set, find the next number to be used in the name for # the default output directory. #------------------------------------------------------------------------------- if ((not $define_new_output_dir) and (not $overwrite_output_dir)) { my $dir_id = 1; while (-d "er.".$dir_id.".html") { $dir_id++; } $outputdir = "er.".$dir_id.".html"; } if (-d $outputdir) { #------------------------------------------------------------------------------- # The -o option is used, but the directory already exists. #------------------------------------------------------------------------------- if ($define_new_output_dir) { gp_message ("error", $subr_name, "directory $outputdir already exists"); gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory"); } #------------------------------------------------------------------------------- # This is a bit risky, so we proceed with caution. The output directory exists, # but it is okay to overwrite it. It is removed here and created again below. #------------------------------------------------------------------------------- elsif ($overwrite_output_dir) { my $target_cmd = $g_mapped_cmds{"rm"}; my $rm_output = qx ($target_cmd -rf $outputdir); my $error_code = ${^CHILD_ERROR_NATIVE}; if ($error_code != 0) { gp_message ("error", $subr_name, $rm_output); gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); } else { gp_message ("debug", $subr_name, "directory $outputdir has been removed"); } } } #------------------------------------------------------------------------------- # When we get here, the fatal scenarios have been cleared and the name for # $outputdir is known. Time to create it. #------------------------------------------------------------------------------- if (mkdir ($outputdir, 0777)) { gp_message ("debug", $subr_name, "created output directory $outputdir"); } else { gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir"); } return ($outputdir); } #-- End of subroutine define_the_output_directory #------------------------------------------------------------------------------ # Return the virtual address for the load object. # # Note that at this point, $elf_arch is known to be supported. # # TBD: Duplications? #------------------------------------------------------------------------------ sub determine_base_va_address { my $subr_name = get_my_name (); my ($executable_name, $base_va_executable, $loadobj, $routine) = @_; my $name_loadobject; my $base_va_address; gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable"); gp_message ("debugXL", $subr_name, "loadobj = $loadobj"); gp_message ("debugXL", $subr_name, "routine = $routine"); #------------------------------------------------------------------------------ # Strip the pathname from the load object name. #------------------------------------------------------------------------------ $name_loadobject = get_basename ($loadobj); #------------------------------------------------------------------------------ # If the load object is the executable, return the base address determined # earlier. Otherwise return 0x0. Note that I am not sure if this is always # the right thing to do, but for .so files it seems to work out fine. #------------------------------------------------------------------------------ if ($name_loadobject eq $executable_name) { $base_va_address = $base_va_executable; } else { $base_va_address = "0x0"; } my $decimal_address = bigint::hex ($base_va_address); gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)"); return ($base_va_address); } #-- End of subroutine determine_base_va_address #------------------------------------------------------------------------------- # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. #------------------------------------------------------------------------------- sub determine_base_virtual_address { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my $full_path_exec; my $executable_name; my $va_executable_in_hex; my $path_to_map_file; for my $exp_dir (keys %g_exp_dir_meta_data) { $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; $path_to_map_file .= $exp_dir; $path_to_map_file .= "/map.xml"; ($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file); $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec; $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name; $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex; gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec"); gp_message ("debug", $subr_name, "executable_name = $executable_name"); gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); } return (0); } #-- End of subroutine determine_base_virtual_address #------------------------------------------------------------------------------ # Determine whether the decimal separator is a point or a comma. #------------------------------------------------------------------------------ sub determine_decimal_separator { my $subr_name = get_my_name (); my $ignore_count; my $decimal_separator; my $convert_to_dot; my $field; my $target_found; my $error_code; my $cmd_output; my $target_cmd; my @locale_info; my $default_decimal_separator = "\\."; $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC"; ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); if ($error_code != 0) #------------------------------------------------------------------------------- # This is unlikely to happen, but you never know. To reduce the nesting level, # return right here in case of an error. #------------------------------------------------------------------------------- { gp_message ("error", $subr_name, "failure to execute the command $target_cmd"); $convert_to_dot = $TRUE; return ($error_code, $default_decimal_separator, $convert_to_dot); } #------------------------------------------------------------------------------- # Scan the locale info and search for the target line of the form # decimal_point="<target>" where <target> is either a dot, or a comma. #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- # Split the output into the different lines and scan for the line we need. #------------------------------------------------------------------------------- @locale_info = split ("\n", $cmd_output); $target_found = $FALSE; for my $line (@locale_info) { chomp ($line); gp_message ("debug", $subr_name, "line from locale_info = $line"); if ($line =~ /decimal_point=/) { #------------------------------------------------------------------------------- # Found the target line. Split this line to get the value field. #------------------------------------------------------------------------------- my @split_line = split ("=", $line); #------------------------------------------------------------------------------- # There should be 2 fields. If not, something went wrong. #------------------------------------------------------------------------------- if (scalar @split_line != 2) { # if (scalar @split_line == 2) { # $target_found = $FALSE; #------------------------------------------------------------------------------- # Remove the newline before printing the variables. #------------------------------------------------------------------------------- $ignore_count = chomp ($line); $ignore_count = chomp (@split_line); gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format"); gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields"); gp_message ("debug", $subr_name, "warning - the default decimal separator will be used"); } else { #------------------------------------------------------------------------------- # We know there are 2 fields and the second one has the decimal point. #------------------------------------------------------------------------------- gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]"); chomp ($split_line[1]); $field = $split_line[1]; if (length ($field) != 3) #------------------------------------------------------------------------------- # The field still includes the quotes. Check if the string has length 3, which # should be the case, but if not, we flag an error. The error code is set such # that the callee will know a problem has occurred. #------------------------------------------------------------------------------- { gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field"); $error_code = 1; last; } gp_message ("debug", $subr_name, "field = ->$field<-"); if (($field eq "\".\"") or ($field eq "\",\"")) #------------------------------------------------------------------------------- # Found the separator. Capture the character between the quotes. #------------------------------------------------------------------------------- { $target_found = $TRUE; $decimal_separator = substr ($field,1,1); gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop"); last; } } } } if (not $target_found) { $decimal_separator = $default_decimal_separator; gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator"); } if ($decimal_separator ne ".") { $convert_to_dot = $TRUE; } else { $convert_to_dot = $FALSE; } $decimal_separator = "\\".$decimal_separator; $g_locale_settings{"decimal_separator"} = $decimal_separator; $g_locale_settings{"convert_to_dot"} = $convert_to_dot; return ($error_code, $decimal_separator, $convert_to_dot); } #-- End of subroutine determine_decimal_separator #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub dump_function_info { my $subr_name = get_my_name (); my ($function_info_ref, $name) = @_; my %function_info = %{$function_info_ref}; my $kip; gp_message ("debug", $subr_name, "function_info for $name"); $kip = 0; for my $farray ($function_info{$name}) { for my $elm (@{$farray}) { gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}"); for my $key (sort keys %{$elm}) { if ($key eq "routine") { next; } gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}"); } $kip++; } } return (0); } #-- End of subroutine dump_function_info #------------------------------------------------------------------------------ # This is an early scan to find the settings for some options very early on. # For practical reasons the main option parsing and handling is done later, # but without this early scan, these options will not be enabled until later # in the execution. # # This early scan fixes that, but it is not very elegant to do it this way # and in the future, this will be improved. For now it gets the job done. #------------------------------------------------------------------------------ sub early_scan_specific_options { my $subr_name = get_my_name (); my @options_with_value = qw /verbose warnings debug quiet/; my $target_option; my $ignore_value; my $found_option; my $option_requires_value; my $option_value; my $valid_input; my @error_messages = (); $option_requires_value = $TRUE; for (@options_with_value) { $target_option = $_; ($found_option, $option_value) = find_target_option ( \@ARGV, $option_requires_value, $target_option); if ($found_option) { #------------------------------------------------------------------------------ # This part has been set up such that we can support other options too, should # this become necessary. # # A necessary, but limited check for the validity of a value is performed. # This avoids that an error message shows up twice later on. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # All option values are converted to lower case. This makes the checks easier. #------------------------------------------------------------------------------ if ($target_option eq "verbose") { my $verbose_value = lc ($option_value); $valid_input = verify_if_input_is_valid ($verbose_value, "onoff"); if ($valid_input) { $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE; if ($verbose_value eq "on") #------------------------------------------------------------------------------ # Set the status and disable output buffering in verbose mode. #------------------------------------------------------------------------------ { $g_user_settings{"verbose"}{"current_value"} = "on"; STDOUT->autoflush (1); } elsif ($verbose_value eq "off") { $g_user_settings{"verbose"}{"current_value"} = "off"; } } else { my $msg = "$option_value is not supported for the verbose option"; push (@error_messages, $msg); } } elsif ($target_option eq "warnings") { my $warnings_value = lc ($option_value); $valid_input = verify_if_input_is_valid ($warnings_value, "onoff"); if ($valid_input) { $g_warnings = ($warnings_value eq "on") ? $TRUE : $FALSE; if ($warnings_value eq "on") #------------------------------------------------------------------------------ # Set the status and disable output buffering if warnings are enabled. #------------------------------------------------------------------------------ { $g_user_settings{"warnings"}{"current_value"} = "on"; STDOUT->autoflush (1); } elsif ($warnings_value eq "off") { $g_user_settings{"warnings"}{"current_value"} = "off"; } } else { my $msg = "$option_value is not supported for the warnings option"; push (@error_messages, $msg); } } elsif ($target_option eq "quiet") { my $quiet_value = lc ($option_value); $valid_input = verify_if_input_is_valid ($option_value, "onoff"); if ($valid_input) { $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE; if ($quiet_value eq "on") { $g_user_settings{"quiet"}{"current_value"} = "on"; } elsif ($quiet_value eq "off") { $g_user_settings{"quiet"}{"current_value"} = "off"; } } else { my $msg = "$option_value is not supported for the quiet option"; push (@error_messages, $msg); } } elsif ($target_option eq "debug") { my $debug_value = lc ($option_value); $valid_input = verify_if_input_is_valid ($debug_value, "size"); if ($valid_input) { if ($debug_value ne "off") #------------------------------------------------------------------------------ # Disable output buffering in debug mode. #------------------------------------------------------------------------------ { $g_user_settings{"debug"}{"current_value"} = "on"; STDOUT->autoflush (1); } #------------------------------------------------------------------------------ # This function also sets $g_user_settings{"debug"}{"current_value"}. #------------------------------------------------------------------------------ my $ignore_value = set_debug_size (\$debug_value); } else { my $msg = "$option_value is not supported for the debug option"; push (@error_messages, $msg); } } else { my $msg = "target option $target_option not expected"; gp_message ("assertion", $subr_name, $msg); } } } #------------------------------------------------------------------------------ # Check for input errors. #------------------------------------------------------------------------------ my $input_errors = scalar (@error_messages); if ($input_errors > 0) { my $plural = ($input_errors == 1) ? "is one error" : "are $input_errors errors"; print "There " . $plural . " in the options:\n"; for my $i (0 .. $#error_messages) { print "- $error_messages[$i]\n"; } exit (0); } #------------------------------------------------------------------------------ # If quiet mode has been enabled, disable verbose, warnings and debug. #------------------------------------------------------------------------------ if ($g_quiet) { $g_user_settings{"verbose"}{"current_value"} = "off"; $g_user_settings{"warnings"}{"current_value"} = "off"; $g_user_settings{"debug"}{"current_value"} = "off"; $g_verbose = $FALSE; $g_warnings = $FALSE; my $debug_off = "off"; my $ignore_value = set_debug_size (\$debug_off); } return (0); } #-- End of subroutine early_scan_specific_options #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub elf_phdr { my $subr_name = get_my_name (); my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; my %elf_rats = %{$elf_rats_ref}; my $return_value; #------------------------------------------------------------------------------ # TBD. Quick check. Can be moved up the call tree. #------------------------------------------------------------------------------ if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") ) { gp_message ("abort", $subr_name, "$elf_arch is not a supported OS"); } #------------------------------------------------------------------------------ # TBD: This should not be in a loop over $loadobj and only use the executable. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # TBD: $routine is not really used in these subroutines. Is this a bug? #------------------------------------------------------------------------------ if ($elf_loadobjects_found) { gp_message ("debugXL", $subr_name, "calling elf_phdr_usual"); $return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats); } else { gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes"); $return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR); } gp_message ("debug", $subr_name, "the return value = $return_value"); if (not $return_value) { gp_message ("abort", $subr_name, "need to handle a return value of FALSE"); } return ($return_value); } #-- End of subroutine elf_phdr #------------------------------------------------------------------------------ # Return the virtual address for the load object. #------------------------------------------------------------------------------ sub elf_phdr_sometimes { my $subr_name = get_my_name (); my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR) = @_; my $arch_uname_s = $local_system_config{"kernel_name"}; my $arch_uname = $local_system_config{"processor"}; my $arch = $g_arch_specific_settings{"arch"}; gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); gp_message ("debug", $subr_name, "arch = $arch"); my $target_cmd; my $command_string; my $error_code; my $cmd_output; my $line; my $blo; my $elf_offset; my $i; my @foo; my $foo; my $foo1; my $p_vaddr; my $rc; my $archives_file; my $loadobj_SAVE; my $Offset; my $VirtAddr; my $PhysAddr; my $FileSiz; my $MemSiz; my $Flg; my $Align; if ($ARCHIVES_MAP_NAME eq $blo) { return ($ARCHIVES_MAP_VADDR); } else { return ($FALSE); } if ($arch_uname_s ne $elf_arch) { #------------------------------------------------------------------------------ # We are masquerading between systems, must leave #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); return ($FALSE); } if ($loadobj eq "DYNAMIC_FUNCTIONS") #------------------------------------------------------------------------------ # Linux vDSO, leave for now #------------------------------------------------------------------------------ { return ($FALSE); } # TBD: STILL NEEDED??!! $loadobj_SAVE = $loadobj; $blo = get_basename ($loadobj); gp_message ("debug", $subr_name, "loadobj = $loadobj"); gp_message ("debug", $subr_name, "blo = $blo"); gp_message ("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); gp_message ("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); if ($ARCHIVES_MAP_NAME eq $blo) { return ($ARCHIVES_MAP_VADDR); } else { return ($FALSE); } } #-- End of subroutine elf_phdr_sometimes #------------------------------------------------------------------------------ # Return the virtual address for the load object. # # Note that at this point, $elf_arch is known to be supported. #------------------------------------------------------------------------------ sub elf_phdr_usual { my $subr_name = get_my_name (); my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_; my %elf_rats = %{$elf_rats_ref}; my $return_code; my $cmd_output; my $target_cmd; my $command_string; my $error_code; my $error_code1; my $error_code2; my ($elf_offset, $loadobjARC); my ($i, @foo, $foo, $foo1, $p_vaddr, $rc); my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align); my $arch_uname_s = $local_system_config{"kernel_name"}; gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"); my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj); gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj)); if ($elf_arch eq "Linux") { if ($arch_uname_s ne $elf_arch) { #------------------------------------------------------------------------------ # We are masquerading between systems, must leave. # Maybe we could use ELF_RATS #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); return ($FALSE); } if ($loadobj eq "DYNAMIC_FUNCTIONS") { #------------------------------------------------------------------------------ # Linux vDSO, leave for now #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "early return: loadobj = $loadobj"); return ($FALSE); } $target_cmd = $g_mapped_cmds{"readelf"}; $command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null"; ($error_code1, $cmd_output) = execute_system_cmd ($command_string); gp_message ("debug", $subr_name, "executed command_string = $command_string"); gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); if ($error_code1 != 0) { gp_message ("debug", $subr_name, "call failure for $command_string"); #------------------------------------------------------------------------------ # e.g. $loadobj->/usr/lib64/libc-2.17.so #------------------------------------------------------------------------------ $loadobjARC = get_basename ($loadobj); gp_message ("debug", $subr_name, "seek elf_rats for $loadobjARC"); if (exists ($elf_rats{$loadobjARC})) { my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]"; $target_cmd = $g_mapped_cmds{"readelf"}; $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null"; ($error_code2, $cmd_output) = execute_system_cmd ($command_string); if ($error_code2 != 0) { gp_message ("abort", $subr_name, "call failure for $command_string"); } else { gp_message ("debug", $subr_name, "executed command_string = $command_string"); gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); } } else { my $msg = "elf_rats{$loadobjARC} does not exist"; gp_message ("assertion", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Example output of "readelf -l" on Linux: # # Elf file type is EXEC (Executable file) # Entry point 0x4023a0 # There are 11 program headers, starting at offset 64 # # Program Headers: # Type Offset VirtAddr PhysAddr # FileSiz MemSiz Flags Align # PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040 # 0x0000000000000268 0x0000000000000268 R 8 # INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8 # 0x000000000000001c 0x000000000000001c R 1 # [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2] # LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 # 0x0000000000001310 0x0000000000001310 R 1000 # LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000 # 0x0000000000006515 0x0000000000006515 R E 1000 # LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000 # 0x000000000006f5a8 0x000000000006f5a8 R 1000 # LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 # 0x000000000000047c 0x0000000000000f80 RW 1000 # DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8 # 0x0000000000000220 0x0000000000000220 RW 8 # NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4 # 0x0000000000000044 0x0000000000000044 R 4 # GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4 # 0x000000000000020c 0x000000000000020c R 4 # GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000 # 0x0000000000000000 0x0000000000000000 RW 10 # GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 # 0x0000000000000238 0x0000000000000238 R 1 # # Section to Segment mapping: # Segment Sections... # 00 # 01 .interp # 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt # 03 .init .plt .text .fini # 04 .rodata .eh_frame_hdr .eh_frame # 05 .init_array .fini_array .dynamic .got .got.plt .data .bss # 06 .dynamic # 07 .note.gnu.build-id .note.ABI-tag # 08 .eh_frame_hdr # 09 # 10 .init_array .fini_array .dynamic .got #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Analyze the ELF information and try to find the virtual address. # # Note that the information printed as part of LOAD needs to have "R E" in it. # In the example output above, the return value would be "0x0000000000402000". # # We also need to distinguish two cases. It could be that the output is on # a single line, or spread over two lines: # # Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align # LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000 # or 2 lines # LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 # 0x0000000000001010 0x0000000000001010 R E 200000 #------------------------------------------------------------------------------ @foo = split ("\n",$cmd_output); for $i (0 .. $#foo) { $foo = $foo[$i]; chomp ($foo); if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) { $Offset = $1; $VirtAddr = $2; $PhysAddr = $3; $FileSiz = $4; $MemSiz = $5; $Flg = $6; $Align = $7; $elf_offset = $VirtAddr; gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset"); return ($elf_offset); } elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/) { #------------------------------------------------------------------------------ # is it a two line version? #------------------------------------------------------------------------------ $Offset = $1; $VirtAddr = $2; # maybe $PhysAddr = $3; if ($i != $#foo) { $foo1 = $foo[$i + 1]; chomp ($foo1); if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) { $FileSiz = $1; $MemSiz = $2; $Flg = $3; $Align = $4; $elf_offset = $VirtAddr; gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset"); return ($elf_offset); } } } } } elsif ($elf_arch eq "SunOS") { #------------------------------------------------------------------------------ #Program Header[3]: # p_vaddr: 0x10000 p_flags: [ PF_X PF_R ] # folowed by # p_paddr: 0 p_type: [ PT_LOAD ] #------------------------------------------------------------------------------ if ($arch_uname_s ne $elf_arch) #------------------------------------------------------------------------------ # we are masquerading between systems, must leave #------------------------------------------------------------------------------ { gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch"); return (0); } $target_cmd = $g_mapped_cmds{"elfdump"}; $command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null"; ($error_code, $cmd_output) = execute_system_cmd ($command_string); if ($error_code != 0) { gp_message ("debug", $subr_name,"call failure for $command_string"); die ("$target_cmd call failure"); } my @foo = split ("\n",$cmd_output); for $i (0 .. $#foo) { $foo = $foo[$i]; chomp ($foo); if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/) { $p_vaddr = $1; # probably if ($i != $#foo) { $foo1 = $foo[$i + 1]; chomp ($foo1); if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/) { $elf_offset = $p_vaddr; return ($elf_offset); } } } } } } #-- End of subroutine elf_phdr_usual #------------------------------------------------------------------------------ # Execute a system command. In case of an error, a non-zero error code is # returned. It is upon the caller to decide what to do next. #------------------------------------------------------------------------------ sub execute_system_cmd { my $subr_name = get_my_name (); my ($target_cmd) = @_; chomp ($target_cmd); my $cmd_output = qx ($target_cmd); my $error_code = ${^CHILD_ERROR_NATIVE}; if ($error_code != 0) { gp_message ("error", $subr_name, "failure executing command $target_cmd"); gp_message ("error", $subr_name, "error code = $error_code"); } else { chomp ($cmd_output); gp_message ("debugM", $subr_name, "executed command $target_cmd"); gp_message ("debugM", $subr_name, "cmd_output = $cmd_output"); } return ($error_code, $cmd_output); } #-- End of subroutine execute_system_cmd #------------------------------------------------------------------------------ # Scan the input file, which should be a gprofng generated map.xml file, and # extract the relevant information. #------------------------------------------------------------------------------ sub extract_info_from_map_xml { my $subr_name = get_my_name (); my ($input_map_xml_file) = @_; my $extracted_information; my $input_line; my $vaddr; my $foffset; my $modes; my $name_path; my $name; my $full_path_exec; my $executable_name; my $va_executable_in_hex; open (MAP_XML, "<", $input_map_xml_file) or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!"); gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading"); #------------------------------------------------------------------------------ # Scan the file. We need to find the name of the executable with the mode set # to 0x005. For this entry we have to capture the name, the mode, the virtual # address and the offset. #------------------------------------------------------------------------------ $extracted_information = $FALSE; while (<MAP_XML>) { $input_line = $_; chomp ($input_line); gp_message ("debug", $subr_name, "read input_line = $input_line"); if ($input_line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) { gp_message ("debug", $subr_name, "target line = $input_line"); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); #------------------------------------------------------------------------------ # The base virtual address is calculated as vaddr-foffset. Although Perl # handles arithmetic in hex, we take the safe way here. Maybe overkill, but # I prefer to be safe than sorry in cases like this. #------------------------------------------------------------------------------ $full_path_exec = $name_path; $executable_name = $name; my $result_VA = 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"); #------------------------------------------------------------------------------ # Stop reading when we found the correct entry. #------------------------------------------------------------------------------ if ($modes eq "005") { $extracted_information = $TRUE; last; } } } #-- End of while-loop if (not $extracted_information) { my $msg = "cannot find the necessary information in file $input_map_xml_file"; gp_message ("assertion", $subr_name, $msg); } gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec"); gp_message ("debug", $subr_name, "executable_name = $executable_name"); gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); return ($full_path_exec, $executable_name, $va_executable_in_hex); } #-- End of subroutine extract_info_from_map_xml #------------------------------------------------------------------------------ # This routine analyzes the metric line and extracts the metric specifics # from it. # Example input: Exclusive Total CPU Time: e.%totalcpu #------------------------------------------------------------------------------ sub extract_metric_specifics { my $subr_name = get_my_name (); my ($metric_line) = @_; my $metric_description; my $metric_flavor; my $metric_visibility; my $metric_name; my $metric_spec; # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) { gp_message ("debug", $subr_name, "line of interest: $metric_line"); $metric_description = $1; $metric_flavor = $2; $metric_visibility = $3; $metric_name = $4; #------------------------------------------------------------------------------ # Although we have captured the metric visibility, the original code removes # this from the name. Since the structure is more complicated, the code is # more tedious as well. With our new approach we just leave the visibility # out. #------------------------------------------------------------------------------ # $metric_spec = $metric_flavor.$metric_visibility.$metric_name; $metric_spec = $metric_flavor . "." . $metric_name; #------------------------------------------------------------------------------ # From the original code: # # On x64 systems there are metrics which contain ~ (for example # DC_access~umask=0 . When er_print lists them, they come out # as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is # fixed, we need this. Later we may need something else, or # things may just work. #------------------------------------------------------------------------------ # $metric_spec=~s/\%7e\%/,/; # # remove % metric # print "DB: before \$metric_spec = $metric_spec\n"; #------------------------------------------------------------------------------ # TBD: I don't know why the "%" symbol is removed. #------------------------------------------------------------------------------ # $metric_spec =~ s/\%//; # print "DB: after \$metric_spec = $metric_spec\n"; return ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description); } else { return ("skipped", "void"); } } #-- End of subroutine extract_metric_specifics #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub extract_source_line_number { my $subr_name = get_my_name (); my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_; #------------------------------------------------------------------------------ # The regex section. #------------------------------------------------------------------------------ my $find_dot_regex = '\.'; my @fields_in_line = (); my $hot_line; my $line_id; #------------------------------------------------------------------------------ # To extract the source line number, we need to distinguish whether this is # a line with, or without metrics. #------------------------------------------------------------------------------ @fields_in_line = split (" ", $input_line); if ( $input_line =~ /$src_times_regex/ ) { $hot_line = $1; if ($hot_line eq "##") #------------------------------------------------------------------------------ # The line id comes after the "##" symbol and the metrics. #------------------------------------------------------------------------------ { $line_id = $fields_in_line[$number_of_metrics+1]; } else #------------------------------------------------------------------------------ # The line id comes after the metrics. #------------------------------------------------------------------------------ { $line_id = $fields_in_line[$number_of_metrics]; } } elsif ($input_line =~ /$function_regex/) { $line_id = "func"; } else #------------------------------------------------------------------------------ # The line id is the first non-blank element. #------------------------------------------------------------------------------ { $line_id = $fields_in_line[0]; } #------------------------------------------------------------------------------ # Remove the trailing dot. #------------------------------------------------------------------------------ $line_id =~ s/$find_dot_regex//; return ($line_id); } #-- End of subroutine extract_source_line_number #------------------------------------------------------------------------------ # For a give routine name and address, find the index into the # function_info array #------------------------------------------------------------------------------ sub find_index_in_function_info { my $subr_name = get_my_name (); my ($routine_ref, $current_address_ref, $function_info_ref) = @_; my $routine = ${ $routine_ref }; my $current_address = ${ $current_address_ref }; my @function_info = @{ $function_info_ref }; my $addr_offset; my $ref_index; gp_message ("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address"); if (exists ($g_multi_count_function{$routine})) { # TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); for my $ref (keys @{ $g_map_function_to_index{$routine} }) { $ref_index = $g_map_function_to_index{$routine}[$ref]; gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); $addr_offset = $function_info[$ref_index]{"addressobjtext"}; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); $addr_offset =~ s/^@\d+://; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); if ($addr_offset eq $current_address) { last; } } } else { #------------------------------------------------------------------------------ # There is only a single occurrence and it is straightforward to get the index. #------------------------------------------------------------------------------ if (exists ($g_map_function_to_index{$routine})) { $ref_index = $g_map_function_to_index{$routine}[0]; } else { my $msg = "index for $routine cannot be determined"; gp_message ("assertion", $subr_name, $msg); } } gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index"); return (\$ref_index); } #-- End of subroutine find_index_in_function_info #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub find_keyword_in_string { my $subr_name = get_my_name (); my ($target_string_ref, $target_keyword_ref) = @_; my $target_string = ${ $target_string_ref }; my $target_keyword = ${ $target_keyword_ref }; my $foundit = $FALSE; my @index_values = (); my $ret_val = 0; my $offset = 0; gp_message ("debugXL", $subr_name, "target_string = $target_string"); $ret_val = index ($target_string, $target_keyword, $offset); gp_message ("debugXL", $subr_name, "ret_val = $ret_val"); if ($ret_val != -1) { $foundit = $TRUE; while ($ret_val != -1) { push (@index_values, $ret_val); $offset = $ret_val + 1; gp_message ("debugXL", $subr_name, "ret_val = $ret_val offset = $offset"); $ret_val = index ($target_string, $target_keyword, $offset); } for my $i (keys @index_values) { gp_message ("debugXL", $subr_name, "index_values[$i] = $index_values[$i]"); } } else { gp_message ("debugXL", $subr_name, "target keyword $target_keyword not found"); } return (\$foundit, \@index_values); } #-- End of subroutine find_keyword_in_string #------------------------------------------------------------------------------ # Retrieve the absolute path that was used to execute the command. This path # is used to execute gp-display-text later on. #------------------------------------------------------------------------------ sub find_path_to_gp_display_text { my $subr_name = get_my_name (); my ($full_command_ref) = @_; my $full_command = ${ $full_command_ref }; my $error_occurred = $TRUE; my $return_value; #------------------------------------------------------------------------------ # Get the path name. #------------------------------------------------------------------------------ my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($full_command); gp_message ("debug", $subr_name, "full_command = $full_command"); gp_message ("debug", $subr_name, "gp_path = $gp_path"); my $gp_display_text_instance = $gp_path . $GP_DISPLAY_TEXT; #------------------------------------------------------------------------------ # Check if $GP_DISPLAY_TEXT exists, is not empty, and executable. #------------------------------------------------------------------------------ if (not -e $gp_display_text_instance) { $return_value = "file not found"; } else { if (is_file_empty ($gp_display_text_instance)) { $return_value = "file is empty"; } else { #------------------------------------------------------------------------------ # All is well. Capture the path. #------------------------------------------------------------------------------ $error_occurred = $FALSE; $return_value = $gp_path; } } return (\$error_occurred, \$return_value); } #-- End of subroutine find_path_to_gp_display_text #------------------------------------------------------------------------------ # Scan the command line to see if the specified option is present. # # Two types of options are supported: options without a value (e.g. --help) or # those that are set to "on" or "off". # # In this phase, we only need to check if a value is valid. If it is, we have # to enable the corresponding global setting. If the value is not valid, we # ignore it, since it will be caught later and a warning message is issued. #------------------------------------------------------------------------------ sub find_target_option { my $subr_name = get_my_name (); my ($command_line_ref, $option_requires_value, $target_option) = @_; my @command_line = @{ $command_line_ref }; my $option_value = undef; my $found_option = $FALSE; my ($command_line_string) = join (" ", @command_line); ## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/) #------------------------------------------------------------------------------ # This does not make any assumptions on the values we are looking for. #------------------------------------------------------------------------------ if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/) { if (defined ($1)) #------------------------------------------------------------------------------ # We have found the option we are looking for. #------------------------------------------------------------------------------ { $found_option = $TRUE; if ($option_requires_value and defined ($2)) #------------------------------------------------------------------------------ # There is a value and it is passed on to the caller. #------------------------------------------------------------------------------ { $option_value = $2; } } } return ($found_option, $option_value); } #-- End of subroutine find_target_option #------------------------------------------------------------------------------ # Find the occurrences of non-space characters in a string and return their # start and end index values(s). #------------------------------------------------------------------------------ sub find_words_in_line { my $subr_name = get_my_name (); my ($input_line_ref) = @_; my $input_line = ${ $input_line_ref }; my $finished = $TRUE; my $space = 0; my $space_position = 0; my $start_word; my $end_word; my @word_delimiters = (); gp_message ("debugXL", $subr_name, "input_line = $input_line"); $finished = $FALSE; while (not $finished) { $space = index ($input_line, " ", $space_position); my $txt = "string search space_position = $space_position "; $txt .= "space = $space"; gp_message ("debugXL", $subr_name, $txt); if ($space != -1) { if ($space > $space_position) { $start_word = $space_position; $end_word = $space - 1; $space_position = $space; my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword"); push (@word_delimiters, [$start_word, $end_word]); } elsif ( ($space == $space_position) and ($space < length ($input_line) - 1)) { $space = $space + 1; $space_position = $space; } else { print "DONE\n"; $finished = $TRUE; gp_message ("debugXL", $subr_name, "completed - finished = $finished"); } } else { $finished = $TRUE; $start_word = $space_position; $end_word = length ($input_line) - 1; my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); push (@word_delimiters, [$start_word, $end_word]); if ($keyword =~ /\s+/) { my $txt = "end search spaces only"; gp_message ("debugXL", $subr_name, $txt); } else { my $txt = "end search start_word = $start_word "; $txt .= "end_word = $end_word "; $txt .= "space_position = $space_position -->$keyword<--"; gp_message ("debugXL", $subr_name, $txt); } } } for my $i (keys @word_delimiters) { gp_message ("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]"); } return (\@word_delimiters); } #-- End of subroutine find_words_in_line #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub function_info { my $subr_name = get_my_name (); my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_; my %LINUX_vDSO = %{ $LINUX_vDSO_ref }; my $index_val; my $address_decimal; my $full_address_field; my $FUNC_FILE_NO_PC; my $off_with_the_PC; my $blanks; my $lblanks; my $lvdso_key; my $line_regex; my %functions_per_metric_indexes = (); my %functions_per_metric_first_index = (); my @order; my ($line,$line_n,$value); my ($df_flag,$n,$u); my ($metric_value,$PC_Address,$routine); my ($is_calls,$metric_ok,$name_regex,$pc_len); my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key); #------------------------------------------------------------------------------ # If the directory name does not end with a "/", add it. #------------------------------------------------------------------------------ my $length_of_string = length ($outputdir); if (rindex ($outputdir, "/") != $length_of_string-1) { $outputdir .= "/"; } gp_message ("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric"); $is_calls = $FALSE; $metric_ok = $TRUE; $off_with_the_PC = rindex ($FUNC_FILE, "-PC"); $FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC); if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func") { $FUNC_FILE_NO_PC = $outputdir."calls"; $is_calls = $TRUE; $metric_ok = $FALSE; } elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func") { $FUNC_FILE_NO_PC = $outputdir."calltree"; $metric_ok = $FALSE; } elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func") { $FUNC_FILE_NO_PC = $outputdir."functions.func"; $metric_ok = $FALSE; } gp_message ("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC"); open (FUNC_FILE, "<", $FUNC_FILE) or die ("Not able to open file $FUNC_FILE for reading - '$!'"); gp_message ("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading"); open (FUNC_FILE_NO_PC, ">", $FUNC_FILE_NO_PC) or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'"); gp_message ("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing"); open (FUNC_FILE_REGEXP, "<", "$FUNC_FILE.name-regex") or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'"); gp_message ("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading"); $name_regex = <FUNC_FILE_REGEXP>; chomp ($name_regex); close (FUNC_FILE_REGEXP); gp_message ("debugXL", $subr_name, "name_regex = $name_regex"); $n = 0; $u = 0; $pc_len = 0; #------------------------------------------------------------------------------ # Note that the double \\ is needed here. The regex used will not have these. #------------------------------------------------------------------------------ if ($is_calls) { #------------------------------------------------------------------------------ # TBD # I do not see the "*" in my test output, but no harm to leave the code in. # # er_print * before PC for calls ! 101315 #------------------------------------------------------------------------------ $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)"; } else { $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)"; } gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." line_regex->$line_regex<-"); gp_message ("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE"); $line_n = 0; $index_val = 0; while (<FUNC_FILE>) { $line = $_; chomp ($line); # gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line"); $line_n++; if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign { #------------------------------------------------------------------------------ # A typical target line looks like this: # 11:0x001492e0 6976.900 <additional_timings> _lwp_start #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "select = $line"); if ($is_calls) { $segment = $3; $offset = $5; $spaces = $6; $rest = $7; $PC_Address = $segment.$4.$offset; # PC Addr. gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7"); } else { $segment = $2; $offset = $4; $spaces = $5; $rest = $6; $PC_Address = $segment.$3.$offset; # PC Addr. gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); } if ($segment == -1) { #------------------------------------------------------------------------------ # presume vDSO field overflow - er_print used an inadequate format # or the fsummary (MASTER) had the wrong format for -1? # rats - get ahead of ourselves - should not be a field abuttal so #------------------------------------------------------------------------------ if ($line =~ /$name_regex/) { if ($metric_ok) { $metric_value = $1; # whatever $routine = $2; } else { $routine = $1; } if ($is_calls) { if (substr ($routine,0,1) eq "*") { $routine = substr ($routine,1); } } for $vdso_key (keys %LINUX_vDSO) { if ($routine eq $LINUX_vDSO{$vdso_key}) { #------------------------------------------------------------------------------ # presume no duplicates - at least can check offset #------------------------------------------------------------------------------ if ($vdso_key =~ /(\d+):(\S+)/) #------------------------------------------------------------------------------ # no -ve segments allowed and not expected #------------------------------------------------------------------------------ { if ($2 eq $offset) { #------------------------------------------------------------------------------ # the real segment #------------------------------------------------------------------------------ $segment = $1; gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE"); $PC_Address = $segment.":".$offset; # PC Addr. gp_message ("debugXL", $subr_name, "vdso line ->$line"); $line = $PC_Address.(' ' x (length ($spaces)-2)).$rest; gp_message ("debugXL", $subr_name, "becomes ->$line"); last; } } } } } else { gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE"); } } #------------------------------------------------------------------------------ # a rotten exception for Linux vDSO # With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file # can have lines like #->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<- #->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<- #->-1:0xff600000 99.040 0 0 [vsyscall]<- # (Real PC Address: 4294967295:0xff600000) #-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<- #-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<- # Rats! # $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"}; #------------------------------------------------------------------------------ $not_printed = $TRUE; for $vdso_key (keys %LINUX_vDSO) { if ($line =~ /^(\s*)($vdso_key)(.*)$/) { $blanks = 1; $rest = 3; $lblanks = length ($blanks); $lvdso_key = length ($vdso_key); $PC_Address = $vdso_key; # PC Addr. $offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key; gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-"); if ($pc_len) { print FUNC_FILE_NO_PC substr ($line,$offy)."\n"; $not_printed = $FALSE; } else { die ("sod1a"); } gp_message ("debugXL", $subr_name, "vdso line ->$line"); if (substr ($line,$lblanks+$lvdso_key,1) eq " ") { #------------------------------------------------------------------------------ # O.K. no field abuttal #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line"); } else { gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line"); $line = $blanks.$vdso_key." ".$rest; } gp_message ("debugXL", $subr_name, "becomes ->$line"); last; } } if ($not_printed) { if ($pc_len) { print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; } else { die ("sod1b"); } $not_printed = $FALSE; } } else { if (!$pc_len) { if ($line =~ /(^\s*PC Addr.\s+)(\S+)/) { $pc_len = length ($1); # say 15 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; } else { print FUNC_FILE_NO_PC "$line\n"; } } else { if ($pc_len) { my $strlen = length ($line); if ($strlen > 0 ) { print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; } else { print FUNC_FILE_NO_PC "\n"; } } else { die ("sod2"); } } next; } $routine = ""; if ($line =~ /$name_regex/) { if ($metric_ok) { $metric_value = $1; # whatever $routine = $2; } else { $routine = $1; } } if ($is_calls) { if (substr ($routine,0,1) eq "*") { $routine = substr ($routine,1); } } if (length ($routine)) { $order[$index_val]{"routine"} = $routine; if ($metric_ok) { $order[$index_val]{"metric_value"} = $metric_value; } $order[$index_val]{"PC Address"} = $PC_Address; $df_flag = 0; if (not exists ($functions_per_metric_indexes{$routine})) { $functions_per_metric_indexes{$routine} = [$index_val]; } else { push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list } gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line"); if ($PC_Address =~ /\s*(\S+):(\S+)/) { my ($segment,$offset); $segment = $1; $offset = $2; $address_decimal = bigint::hex ($offset); # decimal $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280 $order[$index_val]{"addressobj"} = $address_decimal; $order[$index_val]{"addressobjtext"} = $full_address_field; } #------------------------------------------------------------------------------ # Check uniqueness #------------------------------------------------------------------------------ if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address})) { $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val; $u++; #$RI } else { if (!($metric eq "calls" || $metric eq "calltree")) { gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address"); } } $index_val++; gp_message ("debugXL", $subr_name, "updated index_val = $index_val"); $n++; next; } else { if ($n && length ($line)) { my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-"; gp_message ("assertion", $subr_name, $msg); } } } close (FUNC_FILE); close (FUNC_FILE_NO_PC); for my $i (sort keys %functions_per_metric_indexes) { my $values = ""; for my $fields (sort keys @{ $functions_per_metric_indexes{$i} }) { $values .= "$functions_per_metric_indexes{$i}[$fields] "; } gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values"); } return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes); } #-- End of subroutine function_info #------------------------------------------------------------------------------ # Generate a html header. #------------------------------------------------------------------------------ sub generate_a_header { my $subr_name = get_my_name (); my ($page_text_ref, $size_text_ref, $position_text_ref) = @_; my $page_text = ${ $page_text_ref }; my $size_text = ${ $size_text_ref }; my $position_text = ${ $position_text_ref }; my $html_header; $html_header = "<div class=\"" . $position_text . "\">\n"; $html_header .= "<". $size_text . ">\n"; $html_header .= $page_text . "\n"; $html_header .= "</". $size_text . ">\n"; $html_header .= "</div>"; gp_message ("debugXL", $subr_name, "on exit page_title = $html_header"); return (\$html_header); } #-- End of subroutine generate_a_header #------------------------------------------------------------------------------ # Generate the caller-callee information. #------------------------------------------------------------------------------ sub generate_caller_callee { my $subr_name = get_my_name (); my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, $function_address_info_ref, $addressobjtextm_ref, $input_string_ref) = @_; my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my %function_view_structure = %{ $function_view_structure_ref }; my %function_address_info = %{ $function_address_info_ref }; my %addressobjtextm = %{ $addressobjtextm_ref }; my $input_string = ${ $input_string_ref }; my @caller_callee_data = (); my $outfile; my $input_line; my $fullname; my $separator = "cuthere"; my @address_field = (); my @fields = (); my @function_names = (); my @marker = (); my @metric_values = (); my @word_index_values = (); my @header_lines = (); my $all_metrics; my $elements_in_name; my $full_hex_address; my $hex_address; my $file_title; my $page_title; my $size_text; my $position_text; my @html_metric_sort_header = (); my $html_header; my $html_title_header; my $html_home; my $html_acknowledgement; my $html_end; my $html_line; my $marker_target_function; my $max_metrics_length = 0; my $metrics_length; my $modified_line; my $name_regex; my $no_of_fields; my $routine; my $routine_length; my $string_length; my $top_header; my $total_header_lines; my $word_index_values_ref; my $infile; my $outputdir = append_forward_slash ($input_string); my $LANG = $g_locale_settings{"LANG"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator"); gp_message ("debug", $subr_name, "outputdir = $outputdir"); $infile = $outputdir . "caller-callee-PC2"; $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html"; gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile"); open (CALLER_CALLEE_IN, "<", $infile) or die ("unable to open caller file $infile for reading - '$!'"); gp_message ("debug", $subr_name, "opened file $infile for reading"); open (CALLER_CALLEE_OUT, ">", $outfile) or die ("unable to open $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); gp_message ("debug", $subr_name, "building caller-callee file $outfile"); #------------------------------------------------------------------------------ # Generate some of the structures used in the HTML output. #------------------------------------------------------------------------------ $file_title = "Caller-callee overview"; $html_header = ${ create_html_header (\$file_title) }; $html_home = ${ generate_home_link ("right") }; $page_title = "Caller Callee View"; $size_text = "h2"; $position_text = "center"; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; #------------------------------------------------------------------------------ # Read all of the file into array with the name caller_callee_data. #------------------------------------------------------------------------------ chomp (@caller_callee_data = <CALLER_CALLEE_IN>); #------------------------------------------------------------------------------ # Typical structure of the input file: # # Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Functions sorted by metric: Exclusive Total CPU Time # Callers and callees sorted by metric: Attributed Total CPU Time # # PC Addr. Name Attr. Attr. CPU Attr. Attr. # Total Cycles Instructions Last-Level # CPU sec. sec. Executed Cache Misses # 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250 # 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045 # 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205 # # PC Addr. Name Attr. Attr. CPU Attr. Attr. # Total Cycles Instructions Last-Level # CPU sec. sec. Executed Cache Misses # 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045 # 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045 #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Scan the input file. The first lines are assumed to be part of the header, # so we store those. The diagnostic lines that echo some settings are also # stored, but currently not used. #------------------------------------------------------------------------------ my $scan_header = $FALSE; my $scan_caller_callee_data = $FALSE; my $data_function_block = ""; my @function_blocks = (); my $first = $TRUE; my @html_caller_callee = (); my @top_level_header = (); #------------------------------------------------------------------------------ # The regexes. #------------------------------------------------------------------------------ my $empty_line_regex = '^\s*$'; my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)'; my $get_hex_address_regex = '(\d+):0x(\S+)'; my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)'; my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; my $sorted_by_regex = 'sorted by metric:'; my $current_regex = '^Current'; my $get_addr_offset_regex = '^@\d+:'; #------------------------------------------------------------------------------ # Get the length of the first metric field across all lines. This value is # used to pad the first metric with spaces and get the alignment right. # # Scan the input data and find the line(s) with metric values. A complication # is that a function name may consists of more than one field. # # Note. This part could be used to parse the other elements of the input file, # but that makes the loop very complicated. Instead, we re-scan the data # below and process each block separately. # # Since this data is all in memory and relatively small, the performance should # not suffer much, but it does improve the readability of the code. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "determine the maximum length of the first field"); $g_max_length_first_metric = 0; my @hex_addresses = (); my @special_marker = (); my @the_function_name = (); my @the_metrics = (); my @length_first_metric = (); for (my $line = 0; $line <= $#caller_callee_data; $line++) { my $input_line = $caller_callee_data[$line]; if ($input_line =~ /$line_of_interest_regex/) { if (defined ($1) and defined ($2) and defined ($3)) #------------------------------------------------------------------------------ # This is a line of interest, since it has the address, the function name and # the values for the metrics. Examples of valid lines are: # # 2:0x00005028 *xfree_large 0. 0 # 12:0x0004c2b0 munmap 0.143 6402086 # 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0 # # The function name marked with a * is the current target. #------------------------------------------------------------------------------ { my $full_hex_address = $1; my $marker = $2; my $remaining_line = $3; if ($full_hex_address =~ /$get_hex_address_regex/) { $hex_address = "0x" . $2; push (@hex_addresses, $hex_address); gp_message ("debugXL", $subr_name, "pushed $hex_address"); } else { my $msg = "full_hex_address = $full_hex_address has an unknown format"; gp_message ("assertion", $subr_name, $msg); } if ($marker eq "*") { push (@special_marker, "*"); } else { push (@special_marker, "X"); } } else { my $msg = "input_line = $input_line has an unknown format"; gp_message ("assertion", $subr_name, $msg); } my @fields_in_line = split (" ", $input_line); #------------------------------------------------------------------------------ # We stripped the address and marker (if any), off, so this string starts with # the function name. #------------------------------------------------------------------------------ my $remainder = $3; my $number_of_fields = scalar (@fields_in_line); my $words_in_function_name = $number_of_fields - $number_of_metrics - 1; my @remainder_array = split (" ", $remainder); #------------------------------------------------------------------------------ # If the first metric is 0. (or 0, depending on the locale), the calculation # of the length needs to be adjusted, because 0. is really 0.000. # # While we could easily add 3 to the length, we assign a symbolic value to the # first metric (ZZZ) and then compute the length. This makes things clearer. # I hope ;-) #------------------------------------------------------------------------------ my $first_metric = $remainder_array[$words_in_function_name]; if ($first_metric =~ /^0$decimal_separator$/) { gp_message ("debugXL", $subr_name, "fixed up $first_metric"); $first_metric = "0.ZZZ"; } push (@length_first_metric, length ($first_metric)); my $txt = "words in function name = $words_in_function_name "; $txt .= "first_metric = $first_metric length = "; $txt .= length ($first_metric); gp_message ("debugXL", $subr_name, $txt); #------------------------------------------------------------------------------ # Generate the regex for the metrics. # # TBD: This should be an attribute of the function and be done once only. #------------------------------------------------------------------------------ my $m_regex = '(\S+'; for my $f (2 .. $words_in_function_name) { $m_regex .= '\s+\S+'; } #------------------------------------------------------------------------------ # This last part captures all the metric values. #------------------------------------------------------------------------------ $m_regex .= $get_metric_field_regex; gp_message ("debugXL", $subr_name, "m_regex = $m_regex"); gp_message ("debugXL", $subr_name, "remainder = $remainder"); if ($remainder =~ /$m_regex/) { my $func_name = $1; my $its_metrics = $2; my $msg = "found the info - func_name = " . $func_name . " its metrics = " . $its_metrics; gp_message ("debugXL", $subr_name, $msg); push (@the_function_name, $func_name); push (@the_metrics, $its_metrics); } else { my $msg = "remainder string $remainder has an unrecognized format"; gp_message ("assertion", $subr_name, $msg); } $g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric)); my $msg = "first_metric = $first_metric " . "g_max_length_first_metric = $g_max_length_first_metric"; gp_message ("debugXL", $subr_name, $msg); } } gp_message ("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric"); gp_message ("debugXL", $subr_name, "#hex_addresses = $#hex_addresses"); #------------------------------------------------------------------------------ # Main loop over the input data. #------------------------------------------------------------------------------ my $index_start = 0; # 1 my $index_end = -1; # 0 for (my $line = 0; $line <= $#caller_callee_data; $line++) { my $input_line = $caller_callee_data[$line]; if ($input_line =~ /$header_name_regex/) { $scan_header = $TRUE; gp_message ("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first"); } elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/)) { my $msg = "line = " . $line . " captured top level header: " . "input_line = " . $input_line; gp_message ("debugXL", $subr_name, $msg); push (@top_level_header, $input_line); } elsif ($input_line =~ /$line_of_interest_regex/) { $index_end++; $scan_header = $FALSE; $scan_caller_callee_data = $TRUE; $data_function_block .= $separator . $input_line; my $msg = "line = $line updated index_end = $index_end"; gp_message ("debugXL", $subr_name, $msg); } elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data)) { #------------------------------------------------------------------------------ # An empty line is interpreted as the end of the current block and we process # this, including the generation of the html code for this block. #------------------------------------------------------------------------------ $first = $FALSE; $scan_caller_callee_data = $FALSE; gp_message ("debugXL", $subr_name, "new block"); gp_message ("debugXL", $subr_name, "line = $line index_start = $index_start"); gp_message ("debugXL", $subr_name, "line = $line index_end = $index_end"); gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block"); push (@function_blocks, $data_function_block); my ($html_block_prologue_ref, $html_code_function_block_ref) = generate_html_function_blocks ( \$index_start, \$index_end, \@hex_addresses, \@the_metrics, \@length_first_metric, \@special_marker, \@the_function_name, \$separator, $number_of_metrics_ref, \$data_function_block, $function_info_ref, $function_view_structure_ref); my @html_block_prologue = @{ $html_block_prologue_ref }; my @html_code_function_block = @{ $html_code_function_block_ref }; for my $lines (0 .. $#html_code_function_block) { my $msg = "final html_code_function_block[" . $lines . "] = " . $html_code_function_block[$lines]; gp_message ("debugXL", $subr_name, $msg); } $data_function_block = ""; push (@html_caller_callee, @html_block_prologue); push (@html_caller_callee, @header_lines); push (@html_caller_callee, @html_code_function_block); $index_start = $index_end + 1; $index_end = $index_start - 1; gp_message ("debugXL", $subr_name, "line = $line reset index_start = $index_start"); gp_message ("debugXL", $subr_name, "line = $line reset index_end = $index_end"); } #------------------------------------------------------------------------------ # Only capture the first header. They are all identical. #------------------------------------------------------------------------------ if ($scan_header and $first) { if (defined ($4)) { #------------------------------------------------------------------------------ # This group is only defined for the first line of the header. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "header1 = $4"); gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x"); my $newline = "<b>" . $4 . "</b>"; push (@header_lines, $newline); } elsif ($input_line =~ /\s*(.*)/) { #------------------------------------------------------------------------------ # Capture the subsequent header lines. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "headern = $1"); my $newline = "<b>" . $1 . "</b>"; push (@header_lines, $newline); } } } for my $i (0 .. $#header_lines) { gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); } for my $i (0 .. $#function_blocks) { gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]"); } my $number_of_blocks = $#function_blocks + 1; gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:"); for my $i (0 .. $#function_blocks) { #------------------------------------------------------------------------------ # The split produces an empty first field and is why we skip the first field. #------------------------------------------------------------------------------ ## my @entries = split ("cuthere", $function_blocks[$i]); my @entries = split ($separator, $function_blocks[$i]); for my $k (1 .. $#entries) { my $msg = "entries[" . $k . "] = ". $entries[$k]; gp_message ("debugXL", $subr_name, $k . $msg); } } #------------------------------------------------------------------------------ # Parse and process the individual function blocks. #------------------------------------------------------------------------------ for my $i (0 .. $#function_blocks) { my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i]; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # This split produces an empty first field. This is why skip this. #------------------------------------------------------------------------------ my @entries = split ($separator, $function_blocks[$i]); #------------------------------------------------------------------------------ # An example of @entries: # <empty> # 6:0x0003ad20 drand48 0.100 0.084 768240570 0 # 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 #------------------------------------------------------------------------------ for my $k (1 .. $#entries) { my $input_line = $entries[$k]; my $msg = "input_line = entries[" . $k . "] = ". $entries[$k]; gp_message ("debugXL", $subr_name, $msg); @fields = split (" ", $input_line); $no_of_fields = $#fields + 1; $elements_in_name = $no_of_fields - $number_of_metrics - 1; #------------------------------------------------------------------------------ # TBD: Too restrictive. # CHECK CODE IN GENERATE_CALLER_CALLEE #------------------------------------------------------------------------------ if ($elements_in_name == 1) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)'; } elsif ($elements_in_name == 2) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)'; } else #------------------------------------------------------------------------------ # TBD: Handle this better in case a function entry has more than 2 words. #------------------------------------------------------------------------------ { my $msg = "$elements_in_name elements in name exceeds limit"; gp_message ("assertion", $subr_name, $msg); } if ($input_line =~ /$name_regex/) { $full_hex_address = $1; $marker_target_function = $2; $routine = $3; if ($elements_in_name == 1) { $all_metrics = $4; } elsif ($elements_in_name == 2) { $all_metrics = $6; } $metrics_length = length ($all_metrics); $max_metrics_length = max ($max_metrics_length, $metrics_length); if ($full_hex_address =~ /(\d+):0x(\S+)/) { $hex_address = "0x" . $2; } push (@marker, $marker_target_function); push (@address_field, $hex_address); $modified_line = $all_metrics . " " . $routine; push (@metric_values, $all_metrics); gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); push (@function_names, $routine); } } $total_header_lines = $#header_lines + 1; gp_message ("debugXL", $subr_name, "total_header_lines = $total_header_lines"); gp_message ("debugXL", $subr_name, "Final output"); for my $i (keys @header_lines) { gp_message ("debugXL", $subr_name, "$header_lines[$i]"); } for my $i (0 .. $#function_names) { my $msg = $metric_values[$i] . " " . $marker[$i] . $function_names[$i] . "(" . $address_field[$i] . ")"; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check if this function has multiple occurrences. # TBD: Replace by the function call for this. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "check for multiple occurrences"); for my $i (0 .. $#function_names) { my $current_address = $address_field[$i]; my $found_a_match; my $ref_index; my $alt_name; $routine = $function_names[$i]; $alt_name = $routine; gp_message ("debugXL", $subr_name, "checking for routine = $routine"); if (exists ($g_multi_count_function{$routine})) { #------------------------------------------------------------------------------ # TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! #------------------------------------------------------------------------------ $found_a_match = $FALSE; gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); for my $ref (keys @{ $g_map_function_to_index{$routine} }) { $ref_index = $g_map_function_to_index{$routine}[$ref]; gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); $addr_offset =~ s/$get_addr_offset_regex//; gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); if ($addr_offset eq $current_address) { $found_a_match = $TRUE; last; } } gp_message ("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match"); $alt_name = $function_info[$ref_index]{'alt_name'}; } gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); } gp_message ("debugXL", $subr_name, "completed check for multiple occurrences"); #------------------------------------------------------------------------------ # Figure out the column width. Since the columns in the header may include # spaces, we use the first line with metrics for this. #------------------------------------------------------------------------------ my $top_header = $metric_values[0]; my $word_index_values_ref = find_words_in_line (\$top_header); my @word_index_values = @{ $word_index_values_ref }; # $i = 0 0 4 # $i = 1 10 14 # $i = 2 21 31 # $i = 3 35 42 for my $i (keys @word_index_values) { gp_message ("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]"); } } push (@html_metric_sort_header, "<i>"); for my $i (0 .. $#top_level_header) { $html_line = $top_level_header[$i] . "<br>"; push (@html_metric_sort_header, $html_line); } push (@html_metric_sort_header, "</i>"); print CALLER_CALLEE_OUT $html_header; print CALLER_CALLEE_OUT $html_home; print CALLER_CALLEE_OUT $html_title_header; print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats; ## print CALLER_CALLEE_OUT "<br>\n"; ## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header; print CALLER_CALLEE_OUT "<pre>\n"; print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee; print CALLER_CALLEE_OUT "</pre>\n"; #------------------------------------------------------------------------------- # Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------- $html_home = ${ generate_home_link ("left") }; $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; print CALLER_CALLEE_OUT $html_home; print CALLER_CALLEE_OUT "<br>\n"; print CALLER_CALLEE_OUT $html_acknowledgement; print CALLER_CALLEE_OUT $html_end; close (CALLER_CALLEE_OUT); return (0); } #-- End of subroutine generate_caller_callee #------------------------------------------------------------------------------ # Generate the html version of the disassembly file. # # Note to self (TBD) # https://software.intel.com/content/www/us/en/develop/blogs/intel-release-new-technology-specifications-protect-rop-attacks.html #------------------------------------------------------------------------------ sub generate_dis_html { my $subr_name = get_my_name (); my ($target_function_ref, $number_of_metrics_ref, $function_info_ref, $function_address_and_index_ref, $outputdir_ref, $func_ref, $source_line_ref, $metric_ref, $addressobj_index_ref) = @_; my $target_function = ${ $target_function_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my %function_address_and_index = %{ $function_address_and_index_ref }; my $outputdir = ${ $outputdir_ref }; my $func = ${ $func_ref }; my @source_line = @{ $source_line_ref }; my @metric = @{ $metric_ref }; my %addressobj_index = %{ $addressobj_index_ref }; my $dec_instruction_start; my $dec_instruction_end; my $hex_instruction_start; my $hex_instruction_end; my @colour_line = (); my $hot_line; my $metric_values; my $src_line; my $dec_instr_address; my $instruction; my $operands; my $html_new_line = "<br>"; my $add_new_line_before; my $add_new_line_after; my $address_key; my $boldface; my $file; my $filename = $func; my $func_name; my $orig_hex_instr_address; my $hex_instr_address; my $index_string; my $input_metric; my $linenumber; my $name; my $last_address; my $last_address_in_hex; my $file_title; my $html_header; my $html_home; my $html_end; my $branch_regex = $g_arch_specific_settings{"regex"}; my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; my $linksubexp = $g_arch_specific_settings{"linksubexp"}; my $subexp = $g_arch_specific_settings{"subexp"}; my $is_empty; my %branch_target = (); my %branch_target_no_ref = (); my @disassembly_file = (); my %extended_branch_target = (); my %inverse_branch_target = (); my @metrics = (); my @modified_html = (); my $branch_target_ref; my $extended_branch_target_ref; my $branch_target_no_ref_ref; my $branch_address; my $dec_branch_address; my $found_it; my $found_it_ref; my $func_name_in_dis_file; my $hex_branch_target; my $instruction_address; my $instruction_offset; my $link; my $modified_line; my $raw_hex_branch_target; my $src_line_ref; my $threshold_line; my $html_dis_out = $func . ".html"; #------------------------------------------------------------------------------ # The regex section. #------------------------------------------------------------------------------ my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)'; my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]'; my $white_space_regex = '\s+'; my $first_integer_regex = '^\d+$'; my $integer_regex = '\d+'; my $qmark_regex = '\?'; my $src_regex = '(\s*)(\d+)\.(.*)'; my $function_regex = '^(\s*)<Function:\s(.*)>'; my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)"; my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>"; my $control_flow_1_regex = 'j[a-z]+'; my $control_flow_2_regex = 'call'; my $control_flow_3_regex = 'ret'; ## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; ## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; #------------------------------------------------------------------------------ # Dynamic. Computed below. # # TBD: Try to move these up. #------------------------------------------------------------------------------ my $dis_regex; my $metric_regex; gp_message ("debug", $subr_name, "g_branch_regex = $g_branch_regex"); gp_message ("debug", $subr_name, "call_regex = $call_regex"); gp_message ("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex"); my $the_title = set_title ($function_info_ref, $func, "disassembly"); gp_message ("debug", $subr_name, "the_title = $the_title"); $file_title = $the_title; $html_header = ${ create_html_header (\$file_title) }; $html_home = ${ generate_home_link ("right") }; push (@modified_html, $html_header); push (@modified_html, $html_home); push (@modified_html, "<pre>"); #------------------------------------------------------------------------------ # Open the input and output files. #------------------------------------------------------------------------------ open (INPUT_DISASSEMBLY, "<", $filename) or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); gp_message ("debug", $subr_name , "opened file $filename for reading"); open (HTML_OUTPUT, ">", $html_dis_out) or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'"); gp_message ("debug", $subr_name , "opened file $html_dis_out for writing"); #------------------------------------------------------------------------------ # Check if the file is empty #------------------------------------------------------------------------------ $is_empty = is_file_empty ($filename); if ($is_empty) { #------------------------------------------------------------------------------ # The input file is empty. Write a message in the html file and exit. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name ,"file $filename is empty"); my $comment = "No disassembly generated by $tool_name - file $filename is empty"; my $gp_error_file = $outputdir . "gp-listings.err"; my $html_empty_file_ref = html_text_empty_file (\$comment, \$gp_error_file); my @html_empty_file = @{ $html_empty_file_ref }; print HTML_OUTPUT "$_\n" for @html_empty_file; close (HTML_OUTPUT); return (\@source_line); } else { #------------------------------------------------------------------------------ # Read the file into memory. #------------------------------------------------------------------------------ chomp (@disassembly_file = <INPUT_DISASSEMBLY>); gp_message ("debug", $subr_name ,"read file $filename into memory"); } my $max_length_first_metric = 0; my $src_line_no; #------------------------------------------------------------------------------ # First scan through the assembly listing. #------------------------------------------------------------------------------ for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) { my $input_line = $disassembly_file[$line_no]; gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); if ($input_line =~ /$line_of_interest_regex/) { #------------------------------------------------------------------------------ # Found a matching line. Examples are: # 0.370 [37] 4021d1: addsd %xmm0,%xmm1 # ## 1.001 [36] 4021d5: add $0x1,%rax #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2"); if (defined ($2) and defined($1)) { @metrics = split (/$white_space_regex/ ,$1); $src_line_no = $2; } else { my $msg = "$input_line has an unexpected format"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Compute the maximum length of the first metric and pad the field from the # left later on. The fractional part is ignored. #------------------------------------------------------------------------------ my $first_metric = $metrics[0]; my $new_length; if ($first_metric =~ /$first_integer_regex/) { $new_length = length ($first_metric); } else { my @fields = split (/$decimal_separator/, $first_metric); $new_length = length ($fields[0]); } $max_length_first_metric = max ($max_length_first_metric, $new_length); my $msg; $msg = "first_metric = $first_metric " . "max_length_first_metric = $max_length_first_metric"; gp_message ("debugXL", $subr_name, $msg); if ($src_line_no !~ /$qmark_regex/) #------------------------------------------------------------------------------ # The source code line number is known and is stored. #------------------------------------------------------------------------------ { $source_line[$line_no] = $src_line_no; my $msg; $msg = "found an instruction with a source line ref: "; $msg .= "source_line[$line_no] = $source_line[$line_no]"; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check for function calls. If found, get the address offset from $4 and # compute the target address. #------------------------------------------------------------------------------ ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) = check_and_proc_dis_func_call ( \$input_line, \$line_no, \%branch_target, \%extended_branch_target); $found_it = ${ $found_it_ref }; if ($found_it) { %branch_target = %{ $branch_target_ref }; %extended_branch_target = %{ $extended_branch_target_ref }; } #------------------------------------------------------------------------------ # Look for a branch instruction, or the special endbr32/endbr64 instruction # that is also considered to be a branch target. Note that the latter is x86 # specific. #------------------------------------------------------------------------------ ($found_it_ref, $branch_target_ref, $extended_branch_target_ref, $branch_target_no_ref_ref) = check_and_proc_dis_branches ( \$input_line, \$line_no, \%branch_target, \%extended_branch_target, \%branch_target_no_ref); $found_it = ${ $found_it_ref }; if ($found_it) { %branch_target = %{ $branch_target_ref }; %extended_branch_target = %{ $extended_branch_target_ref }; %branch_target_no_ref = %{ $branch_target_no_ref_ref }; } } } #-- End of loop over line_no %inverse_branch_target = reverse (%extended_branch_target); gp_message ("debug", $subr_name, "generated inverse of branch target structure"); gp_message ("debug", $subr_name, "completed parsing file $filename"); for my $key (sort keys %branch_target) { gp_message ("debug", $subr_name, "branch_target{$key} = $branch_target{$key}"); } for my $key (sort keys %extended_branch_target) { gp_message ("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}"); } for my $key (sort keys %inverse_branch_target) { gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); } for my $key (sort keys %branch_target_no_ref) { gp_message ("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}"); $inverse_branch_target{$key} = $key; } for my $key (sort keys %inverse_branch_target) { gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); } #------------------------------------------------------------------------------ # Process the disassembly. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Dynamically generate the regexes. #------------------------------------------------------------------------------ $metric_regex = ''; for my $metric_used (1 .. $number_of_metrics) { $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; } $dis_regex = '^(#{2}|\s{2})\s+'; $dis_regex .= '(.*)'; ## $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)'; $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)(.*)'; gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); gp_message ("debugXL", $subr_name, "dis_regex = $dis_regex"); gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); gp_message ("debugXL", $subr_name, "contents of lines array"); #------------------------------------------------------------------------------ # Identify the header lines. Make the minimal assumptions. # # In both cases, the first line after the header has whitespace. This is # followed by: # # - A source line file has "<line_no>." # - A dissasembly file has "<Function:" # # These are the characteristics we use below. #------------------------------------------------------------------------------ for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) { my $input_line = $disassembly_file[$line_no]; gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); if ($input_line =~ /$end_src_header_regex/) { gp_message ("debugXL", $subr_name, "header time is over - hit source line\n"); gp_message ("debugXL", $subr_name, "$1 $2 $3\n"); last; } if ($input_line =~ /$end_dis_header_regex/) { gp_message ("debugXL", $subr_name, "header time is over - hit disassembly line\n"); last; } push (@modified_html, "<i>" . $input_line . "</i>"); } my $line_index = scalar (@modified_html); gp_message ("debugXL", $subr_name, "final line_index = $line_index"); for (my $line_no=0; $line_no <= $line_index-1; $line_no++) { my $msg = " modified_html[$line_no] = $modified_html[$line_no]"; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Source line: # 20. for (int64_t r=0; r<repeat_count; r++) { # # Disassembly: # 0.340 [37] 401fec: addsd %xmm0,%xmm1 # ## 1.311 [36] 401ff0: addq $1,%rax #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Find the hot PCs and store them. #------------------------------------------------------------------------------ my @hot_program_counters = (); my @transposed_hot_pc = (); my @max_metric_values = (); gp_message ("debug", $subr_name, "determine the maximum metric values"); for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) { my $input_line = $disassembly_file[$line_no]; if ( $input_line =~ /$dis_regex/ ) { ## if ( defined ($1) and defined ($2) and defined ($3) and ## defined ($4) and defined ($5) and defined ($6) ) if ( defined ($1) and defined ($2) and defined ($3) and defined ($4) and defined ($5) ) { $hot_line = $1; $metric_values = $2; $src_line = $3; $dec_instr_address = bigint::hex ($4); $instruction = $5; if (defined ($6)) { my $white_space_regex = '\s*'; $operands = $6; $operands =~ s/$white_space_regex//; } if ($hot_line eq "##") { my @metrics = split (" ", $metric_values); push (@hot_program_counters, [@metrics]); } } } } for my $row (keys @hot_program_counters) { my $msg = "$filename row[" . $row . "] = "; for my $col (keys @{$hot_program_counters[$row]}) { $msg .= "$hot_program_counters[$row][$col] "; $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col]; } gp_message ("debugXL", $subr_name, "hot PC = $msg"); } for my $row (keys @transposed_hot_pc) { my $msg = "$filename row[" . $row . "] = "; for my $col (keys @{$transposed_hot_pc[$row]}) { $msg .= "$transposed_hot_pc[$row][$col] "; } gp_message ("debugXL", $subr_name, "$filename transposed = $msg"); } #------------------------------------------------------------------------------ # Get the maximum metric values and if integer, convert to floating-point. # Since it is easier, we transpose the array and access it over the columns. #------------------------------------------------------------------------------ for my $row (0 .. $#transposed_hot_pc) { my $max_val = 0; for my $col (0 .. $#{$transposed_hot_pc[$row]}) { $max_val = max ($transposed_hot_pc[$row][$col], $max_val);; } if ($max_val =~ /$integer_regex/) { $max_val = sprintf ("%f", $max_val); } gp_message ("debugXL", $subr_name, "$filename row = $row max_val = $max_val"); push (@max_metric_values, $max_val); } for my $metric (0 .. $#max_metric_values) { my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]"; gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ # TBD - Integrate this better. # # Scan the instructions to find the instruction address range. This is used # to determine if a branch is external to this function. #------------------------------------------------------------------------------ $dec_instruction_start = undef; $dec_instruction_end = undef; for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) { my $input_line = $disassembly_file[$line_no]; if ( $input_line =~ /$dis_regex/ ) { # if ( defined ($1) and defined ($2) and defined ($3) and ## defined ($4) and defined ($5) and defined ($6) ) if ( defined ($1) and defined ($2) and defined ($3) and defined ($4) and defined ($5) ) { $hot_line = $1; $metric_values = $2; $src_line = $3; $dec_instr_address = bigint::hex ($4); $instruction = $5; ## $operands = $6; if (defined ($6)) { my $white_space_regex = '\s*'; $operands = $6; $operands =~ s/$white_space_regex//; } if (defined ($dec_instruction_start)) { if ($dec_instr_address < $dec_instruction_start) { $dec_instruction_start = $dec_instr_address; } } else { $dec_instruction_start = $dec_instr_address; } if (defined ($dec_instruction_end)) { if ($dec_instr_address > $dec_instruction_end) { $dec_instruction_end = $dec_instr_address; } } else { $dec_instruction_end = $dec_instr_address; } } } } if (defined ($dec_instruction_start) and defined ($dec_instruction_end)) { $hex_instruction_start = sprintf ("%x", $dec_instruction_start); $hex_instruction_end = sprintf ("%x", $dec_instruction_end); my $msg; $msg = "$filename $func dec_instruction_start = " . "$dec_instruction_start (0x$hex_instruction_start)"; gp_message ("debugXL", $subr_name, $msg); $msg = "$filename $func dec_instruction_end = " . "$dec_instruction_end (0x$hex_instruction_end)"; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # This is where all the results from above come together. #------------------------------------------------------------------------------ for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) { my $input_line = $disassembly_file[$line_no]; gp_message ("debugXL", $subr_name, "input_line[$line_no] = $input_line"); if ( $input_line =~ /$dis_regex/ ) { gp_message ("debugXL", $subr_name, "found a disassembly line: $input_line"); if ( defined ($1) and defined ($2) and defined ($3) and defined ($4) and defined ($5) ) { # $branch_target{$hex_branch_target} = 1; # $extended_branch_target{$instruction_address} = $raw_hex_branch_target; $hot_line = $1; $metric_values = $2; $src_line = $3; $orig_hex_instr_address = $4; $instruction = $5; ## $operands = $6; my $msg = "disassembly line: $1 $2 $3 $4 $5"; if (defined ($6)) { $msg .= " \$6 = $6"; my $white_space_regex = '\s*'; $operands = $6; $operands =~ s/$white_space_regex//; } gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Pad the line with the metrics to ensure correct alignment. #------------------------------------------------------------------------------ my $the_length; my @split_metrics = split (" ", $metric_values); my $first_metric = $split_metrics[0]; ## if ($first_metric =~ /^\d+$/) if ($first_metric =~ /$first_integer_regex/) { $the_length = length ($first_metric); } else { my @fields = split (/$decimal_separator/, $first_metric); $the_length = length ($fields[0]); } my $spaces = $max_length_first_metric - $the_length; my $pad = ""; for my $p (1 .. $spaces) { $pad .= " "; } $metric_values = $pad . $metric_values; gp_message ("debugXL", $subr_name, "pad = $pad"); gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); #------------------------------------------------------------------------------ # Since the instruction address variable may change and because we need the # original address without html controls, we use a new variable for the # (potentially) modified address. #------------------------------------------------------------------------------ $hex_instr_address = $orig_hex_instr_address; $add_new_line_before = $FALSE; $add_new_line_after = $FALSE; if ($src_line eq "?") #------------------------------------------------------------------------------ # There is no source line number. Do not add a link. #------------------------------------------------------------------------------ { $modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] '; gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); } else { #------------------------------------------------------------------------------ # There is a source line number. Mark it as link. #------------------------------------------------------------------------------ $src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]"; gp_message ("debugXL", $subr_name, "src_line_ref = $src_line_ref"); gp_message ("debugXL", $subr_name, "hex_instr_address = $hex_instr_address"); $modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' '; gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); } #------------------------------------------------------------------------------ # Mark control flow instructions. Several cases need to be distinguished. # # In all cases we give the instruction a specific color, mark it boldface # and add a new-line after the instruction #------------------------------------------------------------------------------ if ( ($instruction =~ /$control_flow_1_regex/) or ($instruction =~ /$control_flow_2_regex/) or ($instruction =~ /$control_flow_3_regex/) ) { gp_message ("debugXL", $subr_name, "instruction = $instruction is a control flow instruction"); $add_new_line_after = $TRUE; $boldface = $TRUE; $instruction = color_string ($instruction, $boldface, $g_html_color_scheme{"control_flow"}); } if (exists ($extended_branch_target{$hex_instr_address})) #------------------------------------------------------------------------------ # This is a branch instruction and we need to add the target address. # # In case the target address is outside of this load object, the link is # colored differently. # # TBD: Add the name and if possible, a working link to this code. #------------------------------------------------------------------------------ { $branch_address = $extended_branch_target{$hex_instr_address}; $dec_branch_address = bigint::hex ($branch_address); if ( ($dec_branch_address >= $dec_instruction_start) and ($dec_branch_address <= $dec_instruction_end) ) #------------------------------------------------------------------------------ # The instruction is within the range. #------------------------------------------------------------------------------ { $link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]"; } else { #------------------------------------------------------------------------------ # The instruction is outside of the range. Change the color of the link. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "address is outside of range"); $link = "[ <a href='#".$branch_address; $link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>"; $link .= $branch_address."</a> ]"; } gp_message ("debugXL", $subr_name, "address exists new link = $link"); $operands .= ' ' . $link; gp_message ("debugXL", $subr_name, "update #1 modified_line = $modified_line"); } if (exists ($branch_target_no_ref{$hex_instr_address})) { gp_message ("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}"); } ## if (exists ($inverse_branch_target{$hex_instr_address}) or ## exists ($branch_target_no_ref{$hex_instr_address})) if (exists ($inverse_branch_target{$hex_instr_address})) #------------------------------------------------------------------------------ # This is a target address and we need to define the instruction address to be # a label. #------------------------------------------------------------------------------ { $add_new_line_before = $TRUE; my $branch_target = $inverse_branch_target{$hex_instr_address}; my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:"; gp_message ("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address"); gp_message ("debugXL", $subr_name, "inverse exists - add a target target = $target"); $hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>"; gp_message ("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address"); gp_message ("debugXL", $subr_name, "update #2 modified_line = $modified_line"); } $modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands; gp_message ("debugXL", $subr_name, "final modified_line = $modified_line"); #------------------------------------------------------------------------------ # This is a control flow instruction, but it is the last one and we do not # want to add a newline. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html"); gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after"); gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before"); if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) ) { $add_new_line_after = $FALSE; gp_message ("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline"); } if ($add_new_line_before) { #------------------------------------------------------------------------------ # Get the previous line, if any, so that we can check what it is. #------------------------------------------------------------------------------ my $prev_line = pop (@modified_html); if ( defined ($prev_line) ) { gp_message ("debugXL", $subr_name, "prev_line = $prev_line"); #------------------------------------------------------------------------------ # Restore the previously popped line. #------------------------------------------------------------------------------ push (@modified_html, $prev_line); if ($prev_line ne $html_new_line) { gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line"); #------------------------------------------------------------------------------ # There is no new-line yet, so add it. #------------------------------------------------------------------------------ push (@modified_html, $html_new_line); } else { #------------------------------------------------------------------------------ # It was a new-line, so do nothing and continue. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "need to restore $html_new_line"); } } } #------------------------------------------------------------------------------ # Add the newly created line. #------------------------------------------------------------------------------ if ($hot_line eq "##") #------------------------------------------------------------------------------ # Highlight the most expensive line. #------------------------------------------------------------------------------ { $modified_line = set_background_color_string ( $modified_line, $g_html_color_scheme{"background_color_hot"}); } #------------------------------------------------------------------------------ # Sub-highlight the lines close enough to the hot line. #------------------------------------------------------------------------------ else { my @current_metrics = split (" ", $metric_values); for my $metric (0 .. $#current_metrics) { my $current_value; my $max_value; $current_value = $current_metrics[$metric]; #------------------------------------------------------------------------------ # As part of the padding process, non-breaking spaces may have been inserted # in an earlier phase. Temporarily remove these to make sure that the maximum # metric values can be computed. #------------------------------------------------------------------------------ $current_value =~ s/ //g; if (exists ($max_metric_values[$metric])) { $max_value = $max_metric_values[$metric]; gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) { # TBD: abs needed? gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0)) { gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line"); $modified_line = set_background_color_string ( $modified_line, $g_html_color_scheme{"background_color_lukewarm"}); last; } } } } } ## my @max_metric_values = (); push (@modified_html, $modified_line); if ($add_new_line_after) { gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line"); push (@modified_html, $html_new_line); } } else { my $msg = "parsing line $input_line"; gp_message ("assertion", $subr_name, $msg); } } elsif ( $input_line =~ /$src_regex/ ) { if ( defined ($1) and defined ($2) ) { ####### BUG? gp_message ("debugXL", $subr_name, "found a source code line: $input_line"); gp_message ("debugXL", $subr_name, "\$1 = $1"); gp_message ("debugXL", $subr_name, "\$2 = $2"); gp_message ("debugXL", $subr_name, "\$3 = $3"); my $blanks = $1; my $src_line = $2; my $src_code = $3; #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g; my $target = "<a name='line_".$src_line."'>".$src_line.".</a>"; gp_message ("debugXL", $subr_name, "src target = $target $src_code"); my $modified_line = $blanks . $target . $src_code; gp_message ("debugXL", $subr_name, "modified_line = $modified_line"); push (@modified_html, $modified_line); } else { my $msg = "parsing line $input_line"; gp_message ("assertion", $subr_name, $msg); } } elsif ( $input_line =~ /$function_regex/ ) { my $html_name; if (defined ($1) and defined ($2)) { $func_name_in_dis_file = $2; my $spaces = $1; my $boldface = $TRUE; gp_message ("debugXL", $subr_name, "function_name = $2"); my $function_line = "<Function: " . $func_name_in_dis_file . ">"; ##### HACK if ($func_name_in_dis_file eq $target_function) { my $color_function_name = color_string ( $function_line, $boldface, $g_html_color_scheme{"target_function_name"}); my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>"; $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>"; } else { my $color_function_name = color_string ( $function_line, $boldface, $g_html_color_scheme{"non_target_function_name"}); $html_name = "<i>" . $spaces . $color_function_name . "</i>"; } push (@modified_html, $html_name); } else { my $msg = "parsing line $input_line"; gp_message ("assertion", $subr_name, $msg); } } } #------------------------------------------------------------------------------ # Add an extra line with diagnostics. # # TBD: The same is done in process_source but should be done only once. #------------------------------------------------------------------------------ if ($hp_value > 0) { my $rounded_percentage = sprintf ("%.1f", $hp_value); $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; } else { $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; } $html_home = ${ generate_home_link ("left") }; $html_end = ${ terminate_html_document () }; push (@modified_html, "</pre>"); push (@modified_html, $html_new_line); push (@modified_html, $threshold_line); push (@modified_html, $html_home); push (@modified_html, $html_new_line); push (@modified_html, $g_html_credits_line); push (@modified_html, $html_end); for my $i (0 .. $#modified_html) { gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); } for my $i (0 .. $#modified_html) { print HTML_OUTPUT "$modified_html[$i]" . "\n"; } close (HTML_OUTPUT); close (INPUT_DISASSEMBLY); gp_message ("debug", $subr_name, "output is in file $html_dis_out"); gp_message ("debug", $subr_name ,"completed processing disassembly"); undef %branch_target; undef %extended_branch_target; undef %inverse_branch_target; return (\@source_line, \@metric); } #-- End of subroutine generate_dis_html #------------------------------------------------------------------------------ # Generate all the function level information. #------------------------------------------------------------------------------ sub generate_function_level_info { my $subr_name = get_my_name (); my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string, $sort_fields_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my @sort_fields = @{ $sort_fields_ref }; my $expr_name; my $first_metric; my $gp_display_text_cmd; my $gp_functions_cmd; my $ignore_value; my $script_pc_metrics; my $outputdir = append_forward_slash ($input_string); my $script_file_PC = $outputdir."gp-script-PC"; my $result_file = $outputdir."gp-out-PC.err"; my $gp_error_file = $outputdir."gp-out-PC.err"; my $func_limit = $g_user_settings{func_limit}{current_value}; #------------------------------------------------------------------------------ # The number of entries in the Function Overview includes <Total>, but that is # not a concern to the user and we add "1" to compensate for this. #------------------------------------------------------------------------------ $func_limit += 1; gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit"); $expr_name = join (" ", @exp_dir_list); gp_message ("debug", $subr_name, "expr_name = $expr_name"); for my $i (0 .. $#sort_fields) { gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]"); } # Ruud $count = 0; gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files"); open (SCRIPT_PC, ">", $script_file_PC) or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'"); gp_message ("debug", $subr_name, "opened file $script_file_PC for writing"); #------------------------------------------------------------------------------ # Get the list of functions. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Get the first metric. #------------------------------------------------------------------------------ $summary_metrics =~ /^([^:]+)/; $first_metric = $1; $g_first_metric = $1; $script_pc_metrics = "address:$summary_metrics"; gp_message ("debugXL", $subr_name, "$func_limit"); gp_message ("debugXL", $subr_name, "$summary_metrics"); gp_message ("debugXL", $subr_name, "$first_metric"); gp_message ("debugXL", $subr_name, "$script_pc_metrics"); # Temporarily disabled print SCRIPT_PC "# limit $func_limit\n"; # Temporarily disabled print SCRIPT_PC "limit $func_limit\n"; print SCRIPT_PC "# thread_select all\n"; print SCRIPT_PC "thread_select all\n"; #------------------------------------------------------------------------------ # Empty header. #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."header\n"; print SCRIPT_PC "outfile $outputdir"."header\n"; #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; #------------------------------------------------------------------------------ # Not really sorted #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; print SCRIPT_PC "metrics address:name:$summary_metrics\n"; print SCRIPT_PC "# sort $first_metric\n"; print SCRIPT_PC "sort $first_metric\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; #------------------------------------------------------------------------------ # Go through all the possible metrics and sort by each of them. #------------------------------------------------------------------------------ for my $field (@sort_fields) { gp_message ("debug", $subr_name, "sort_fields field = $field"); #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n"; print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n"; print SCRIPT_PC "# sort $field\n"; print SCRIPT_PC "sort $field\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; print SCRIPT_PC "metrics address:name:$summary_metrics\n"; print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n"; print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n"; print SCRIPT_PC "# sort $field\n"; print SCRIPT_PC "sort $field\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; } #------------------------------------------------------------------------------ # Get caller-callee list #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n"; print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n"; print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; print SCRIPT_PC "metrics address:name:$summary_metrics\n"; print SCRIPT_PC "# callers-callees\n"; print SCRIPT_PC "callers-callees\n"; #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; $script_pc_metrics = "address:$call_metrics"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; #------------------------------------------------------------------------------ # Not really sorted #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; #------------------------------------------------------------------------------ # Get caller-callee list #------------------------------------------------------------------------------ print SCRIPT_PC "# callers-callees\n"; print SCRIPT_PC "callers-callees\n"; #------------------------------------------------------------------------------ # Else the output from the next line goes to last sort.func #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n"; print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n"; print SCRIPT_PC "# metrics $script_pc_metrics\n"; print SCRIPT_PC "metrics $script_pc_metrics\n"; if ($g_user_settings{"calltree"}{"current_value"} eq "on") { gp_message ("verbose", $subr_name, "Generate the file with the calltree information"); #------------------------------------------------------------------------------ # Get calltree list #------------------------------------------------------------------------------ print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n"; print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n"; print SCRIPT_PC "# calltree\n"; print SCRIPT_PC "calltree\n"; } #------------------------------------------------------------------------------ # Get the default set of metrics #------------------------------------------------------------------------------ my $full_metrics_ref; my $all_metrics; my $full_function_view = $outputdir . "functions.full"; $full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir); $all_metrics = "address:name:"; $all_metrics .= ${$full_metrics_ref}; gp_message ("debug", $subr_name, "all_metrics = $all_metrics"); #------------------------------------------------------------------------------ # Get the name, address, and full overview of all metrics for all functions #------------------------------------------------------------------------------ print SCRIPT_PC "# limit 0\n"; print SCRIPT_PC "limit 0\n"; print SCRIPT_PC "# metrics $all_metrics\n"; print SCRIPT_PC "metrics $all_metrics\n"; print SCRIPT_PC "# thread_select all\n"; print SCRIPT_PC "thread_select all\n"; print SCRIPT_PC "# sort default\n"; print SCRIPT_PC "sort default\n"; print SCRIPT_PC "# outfile $full_function_view\n"; print SCRIPT_PC "outfile $full_function_view\n"; print SCRIPT_PC "# functions\n"; print SCRIPT_PC "functions\n"; close (SCRIPT_PC); $result_file = $outputdir."gp-out-PC.err"; $gp_error_file = $outputdir.$g_gp_error_logfile; $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit "; $gp_functions_cmd .= "-viewmode machine -compare off "; $gp_functions_cmd .= "-script $script_file_PC $expr_name"; gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information"); $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd"); my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", "execution terminated"); } #------------------------------------------------------------------------------- # Parse the full function view and store the data. #------------------------------------------------------------------------------- my @input_data = (); my $empty_line_regex = '^\s*$'; ## my $full_function_view = $outputdir . "functions.full"; open (ALL_FUNC_DATA, "<", $full_function_view) or die ("$subr_name - unable to open output file $full_function_view for reading '$!'"); gp_message ("debug", $subr_name, "opened file $full_function_view for reading"); chomp (@input_data = <ALL_FUNC_DATA>); my $start_scanning = $FALSE; for (my $line = 0; $line <= $#input_data; $line++) { my $input_line = $input_data[$line]; # if ($input_line =~ /^<Total>\s+.*/) if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/) { $start_scanning = $TRUE; } elsif ($input_line =~ /$empty_line_regex/) { $start_scanning = $FALSE; } if ($start_scanning) { gp_message ("debugXL", $subr_name, "$line: $input_data[$line]"); push (@g_full_function_view_table, $input_data[$line]); my $hex_address; my $full_hex_address = $1; my $routine = $2; my $all_metrics = $3; if ($full_hex_address =~ /(\d+):0x(\S+)/) { $hex_address = "0x" . $2; } $g_function_view_all{$routine}{"hex_address"} = $hex_address; $g_function_view_all{$routine}{"all_metrics"} = $all_metrics; } } for my $i (keys %g_function_view_all) { gp_message ("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}"); } for my $i (keys @g_full_function_view_table) { gp_message ("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]"); } return ($script_pc_metrics); } #-- End of subroutine generate_function_level_info #------------------------------------------------------------------------------ # Generate all the files needed for the function view. #------------------------------------------------------------------------------ sub generate_function_view { my $subr_name = get_my_name (); my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, $function_address_info_ref, $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_; my $directory_name = ${ $directory_name_ref }; my @function_info = @{ $function_info_ref }; my %function_view_structure = %{ $function_view_structure_ref }; my $summary_metrics = ${ $summary_metrics_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my %function_address_info = %{ $function_address_info_ref }; my @sort_fields = @{ $sort_fields_ref }; my @exp_dir_list = @{ $exp_dir_list_ref }; my %addressobjtextm = %{ $addressobjtextm_ref }; my @abs_path_exp_dirs = (); my @experiment_directories; my $target_function; my $html_line; my $ftag; my $routine_length; my %html_source_functions = (); my $href_link; my $infile; my $input_experiments; my $keep_value; my $loadobj; my $address_field; my $address_offset; my $msg; my $exe; my $extra_field; my $new_target_function; my $file_title; my $html_output_file; my $html_function_view; my $overview_file; my $exp_name; my $exp_type; my $html_header; my $routine; my $length_header; my $length_metrics; my $full_index_line; my $acknowledgement; my @full_function_view_line = (); my $spaces; my $size_text; my $position_text; my $html_first_metric_file; my $html_new_line = "<br>"; my $html_acknowledgement; my $html_end; my $html_home; my $page_title; my $html_title_header; my $outputdir = append_forward_slash ($directory_name); my $LANG = $g_locale_settings{"LANG"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; $input_experiments = join (", ", @exp_dir_list); for my $i (0 .. $#exp_dir_list) { my $dir = get_basename ($exp_dir_list[$i]); push @abs_path_exp_dirs, $dir; } $input_experiments = join (", ", @abs_path_exp_dirs); gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); #------------------------------------------------------------------------------ # TBD: This should be done only once and much earlier. #------------------------------------------------------------------------------ @experiment_directories = split (",", $input_experiments); #------------------------------------------------------------------------------ # For every function in the function overview, set up an html structure with # the various hyperlinks. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Core loop that generates an HTML line for each function. #------------------------------------------------------------------------------ my $top_of_table = $FALSE; for my $i (0 .. $#function_info) { if (defined ($function_info[$i]{"alt_name"})) { $target_function = $function_info[$i]{"alt_name"}; } else { my $msg = "function_info[$i]{\"alt_name\"} is not defined"; gp_message ("assertion", $subr_name, $msg); } $html_source_functions{$target_function} = $function_info[$i]{"html function block"}; } for my $i (sort keys %html_source_functions) { gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); } $file_title = "Function view for experiments " . $input_experiments; #------------------------------------------------------------------------------ # Example input file: # Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Functions sorted by metric: Exclusive Total CPU Time # # PC Addr. Name Excl. Excl. CPU Excl. Excl. # Total Cycles Instructions Last-Level # CPU sec. sec. Executed Cache Misses # 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250 # 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045 # 6:0x0003af50 erand48_r 0.080 0.084 768240570 0 # 2:0x00001f7b init_data 0.040 0.028 64020043 200205 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 # ... #------------------------------------------------------------------------------ for my $metric (@sort_fields) { $overview_file = $outputdir . $metric . ".sort.func-PC2"; $exp_type = $metric; if ($metric eq "functions") { $html_function_view .= $g_html_base_file_name{"function_view"} . ".html"; } else { $html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html"; } #------------------------------------------------------------------------------ # The default function view is based upon the first metric in the list. We use # this file in the index.html file. #------------------------------------------------------------------------------ if ($metric eq $g_first_metric) { $html_first_metric_file = $html_function_view; my $txt = "g_first_metric = $g_first_metric "; $txt .= "html_first_metric_file = $html_first_metric_file"; gp_message ("debugXL", $subr_name, $txt); } $html_output_file = $outputdir . $html_function_view; open (FUNCTION_VIEW, ">", $html_output_file) or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); $html_home = ${ generate_home_link ("right") }; $html_header = ${ create_html_header (\$file_title) }; $page_title = "Function View"; $size_text = "h2"; $position_text = "center"; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; print FUNCTION_VIEW $html_header; print FUNCTION_VIEW $html_home; print FUNCTION_VIEW $html_title_header; print FUNCTION_VIEW "$_" for @g_html_experiment_stats; print FUNCTION_VIEW $html_new_line . "\n"; my $function_view_structure_ref = process_function_overview ( \$metric, \$exp_type, \$summary_metrics, \$number_of_metrics, \@function_info, \%function_view_structure, \$overview_file); my %function_view_structure = %{ $function_view_structure_ref }; #------------------------------------------------------------------------------ # Core part: extract the true function name and find the html code for it. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "the final table"); print FUNCTION_VIEW "<pre>\n"; print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} }; my $max_length_header = $function_view_structure{"max header length"}; my $max_length_metrics = $function_view_structure{"max metrics length"}; #------------------------------------------------------------------------------ # Add 4 more spaces for the distance to the function names. Purely cosmetic. #------------------------------------------------------------------------------ my $pad = max ($max_length_metrics, $max_length_header) + 4; my $spaces = ""; for my $i (1 .. $pad) { $spaces .= " "; } #------------------------------------------------------------------------------ # Add extra space for the /blank/*/ marker! #------------------------------------------------------------------------------ $spaces .= " "; my $func_header = $spaces . $function_view_structure{"table name"}; gp_message ("debugXL", $subr_name, "func_header = " . $func_header); print FUNCTION_VIEW $spaces . "<b>" . $function_view_structure{"table name"} . "</b>" . $html_new_line . "\n"; #------------------------------------------------------------------------------ # If the header is longer than the metrics, add spaces to padd the difference. # Also add the same 4 spaces between the metric values and the function name. #------------------------------------------------------------------------------ $pad = 0; if ($max_length_header > $max_length_metrics) { $pad = $max_length_header - $max_length_metrics; } $pad += 4; $spaces = ""; for my $i (1 .. $pad) { $spaces .= " "; } #------------------------------------------------------------------------------ # This is where it literally all comes together. The metrics and function # parts are combined. #------------------------------------------------------------------------------ ## for my $i (keys @{ $function_view_structure{"function table"} }) for my $i (0 .. $#{ $function_view_structure{"function table"} }) { my $p1 = $function_view_structure{"metrics part"}[$i]; my $p2 = $function_view_structure{"function table"}[$i]; $full_index_line = $p1 . $spaces . $p2; push (@full_function_view_line, $full_index_line); } print FUNCTION_VIEW "$_\n" for @full_function_view_line; #------------------------------------------------------------------------------- # Clear the array before filling it up again. #------------------------------------------------------------------------------- @full_function_view_line = (); #------------------------------------------------------------------------------- # Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------- $html_home = ${ generate_home_link ("left") }; $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; print FUNCTION_VIEW "</pre>\n"; print FUNCTION_VIEW $html_home; print FUNCTION_VIEW $html_new_line . "\n"; print FUNCTION_VIEW $html_acknowledgement; print FUNCTION_VIEW $html_end; close (FUNCTION_VIEW); } return (\$html_first_metric_file); } #-- End of subroutine generate_function_view #------------------------------------------------------------------------------ # Generate an html line that links back to index.html. The text can either # be positioned to the left or to the right. #------------------------------------------------------------------------------ sub generate_home_link { my $subr_name = get_my_name (); my ($which_side) = @_; my $html_home_line; if (($which_side ne "left") and ($which_side ne "right")) { my $msg = "which_side = $which_side not supported"; gp_message ("assertion", $subr_name, $msg); } $html_home_line .= "<div class=\"" . $which_side . "\">"; $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"}; $html_home_line .= ".html' style='background-color:"; $html_home_line .= $g_html_color_scheme{"index"}; $html_home_line .= "'><b>Return to main view</b></a>"; $html_home_line .= "</div>"; return (\$html_home_line); } #-- End of subroutine generate_home_link #------------------------------------------------------------------------------ # Generate a block of html for this function block. #------------------------------------------------------------------------------ sub generate_html_function_blocks { my $subr_name = get_my_name (); my ( $index_start_ref, $index_end_ref, $hex_addresses_ref, $the_metrics_ref, $length_first_metric_ref, $special_marker_ref, $the_function_name_ref, $separator_ref, $number_of_metrics_ref, $data_function_block_ref, $function_info_ref, $function_view_structure_ref) = @_; my $index_start = ${ $index_start_ref }; my $index_end = ${ $index_end_ref }; my @hex_addresses = @{ $hex_addresses_ref }; my @the_metrics = @{ $the_metrics_ref }; my @length_first_metric = @{ $length_first_metric_ref }; my @special_marker = @{ $special_marker_ref }; my @the_function_name = @{ $the_function_name_ref}; my $separator = ${ $separator_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my $data_function_block = ${ $data_function_block_ref }; my @function_info = @{ $function_info_ref }; my %function_view_structure = %{ $function_view_structure_ref }; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my @html_block_prologue = (); my @html_code_function_block = (); my @function_lines = (); my @fields = (); my @address_field = (); my @metric_values = (); my @function_names = (); my @final_function_names = (); my @marker = (); my @split_number = (); my @function_tags = (); my $all_metrics; my $current_function_name; my $no_of_fields; my $name_regex; my $full_hex_address; my $hex_address; my $target_function; my $marker_function; my $routine; my $routine_length; my $metrics_length; my $max_metrics_length = 0; my $modified_line; my $string_length; my $addr_offset; my $current_address; my $found_a_match; my $ref_index; my $alt_name; my $length_first_field; my $gap; my $ipad; my $html_line; my $target_tag; my $tag_for_header; my $href_file; my $found_alt_name; my $name_in_header; my $create_hyperlinks; state $first_call = $TRUE; state $reference_length; #------------------------------------------------------------------------------ # If the length of the first metric is less than the maximum over all first # metrics, add spaces to the left to ensure correct alignment. #------------------------------------------------------------------------------ for my $k ($index_start .. $index_end) { my $pad = $g_max_length_first_metric - $length_first_metric[$k]; if ($pad ge 1) { my $spaces = ""; for my $s (1 .. $pad) { $spaces .= " "; } $the_metrics[$k] = $spaces . $the_metrics[$k]; my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]"; gp_message ("debugXL", $subr_name, $msg); } ## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k]; ## gp_message ("debugXL", $subr_name, $end_game); } #------------------------------------------------------------------------------ # An example what @function_lines should look like after the split: # <empty> # 6:0x0003ad20 drand48 0.100 0.084 768240570 0 # 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 #------------------------------------------------------------------------------ @function_lines = split ($separator, $data_function_block); #------------------------------------------------------------------------------ # Parse the individual lines. Replace multi-occurrence functions by their # unique alternative name and mark the target function. # # The above split operation produces an empty first field because the line # starts with the separator. This is why skip the first field. #------------------------------------------------------------------------------ for my $i ($index_start .. $index_end) { my $input_line = $the_metrics[$i]; gp_message ("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]); #------------------------------------------------------------------------------ # In case the last metric is 0. only, we append 3 extra characters that # represent zero. We cannot change the number to 0.000 though because that # has a different interpretation than 0. # In a later phase, the "ZZZ" symbol will be removed again, but for now it # creates consistency in, for example, the length of the metrics part. #------------------------------------------------------------------------------ if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/) { if (defined ($1) ) { my $decimal_point = $decimal_separator; $decimal_point =~ s/\\//; my $txt = "input_line = $input_line = ended with 0"; $txt .= $decimal_point; gp_message ("debugXL", $subr_name, $txt); $the_metrics[$i] .= "ZZZ"; } } $hex_address = $hex_addresses[$i]; $marker_function = $special_marker[$i]; $routine = $the_function_name[$i]; #------------------------------------------------------------------------------ # Get the length of the metrics line before ZZZ is replaced by spaces. #------------------------------------------------------------------------------ $all_metrics = $the_metrics[$i]; $metrics_length = length ($all_metrics); $all_metrics =~ s/ZZZ/ /g; $max_metrics_length = max ($max_metrics_length, $metrics_length); push (@marker, $marker_function); push (@address_field, $hex_address); push (@metric_values, $all_metrics); push (@function_names, $routine); my $index_into_function_info_ref = get_index_function_info ( \$routine, \$hex_addresses[$i], $function_info_ref); my $index_into_function_info = ${ $index_into_function_info_ref }; $target_tag = $function_info[$index_into_function_info]{"tag_id"}; $alt_name = $function_info[$index_into_function_info]{"alt_name"}; #------------------------------------------------------------------------------ # Keep the name of the target function (the one marked with a *) for later use. # This is the tag that identifies the block in the caller-callee output. The # tag is used in the link to the caller-callee in the function overview. #------------------------------------------------------------------------------ if ($marker_function eq "*") { $tag_for_header = $target_tag; $name_in_header = $alt_name; #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g; } push (@final_function_names, $alt_name); push (@function_tags, $target_tag); gp_message ("debugXL", $subr_name, "index_into_function_info = $index_into_function_info"); gp_message ("debugXL", $subr_name, "target_tag = $target_tag"); gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); } #-- End of loop for my $i ($index_start .. $index_end) my $tag_line = "<a id='" . $tag_for_header . "'></a>"; $html_line = "<br>\n"; $html_line .= $tag_line . "Function name: "; $html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>"; $html_line .= "<b>" . $name_in_header . "</b></span>\n"; $html_line .= "<br>"; push (@html_block_prologue, $html_line); gp_message ("debugXL", $subr_name, "the final function block for $name_in_header"); $href_file = $g_html_base_file_name{"caller_callee"} . ".html"; #------------------------------------------------------------------------------ # Process the function blocks and generate the HTML structure for them. #------------------------------------------------------------------------------ for my $i (0 .. $#final_function_names) { $current_function_name = $final_function_names[$i]; gp_message ("debugXL", $subr_name, "current_function_name = $current_function_name"); #------------------------------------------------------------------------------ # Do not add hyperlinks for <Total>. #------------------------------------------------------------------------------ if ($current_function_name eq "<Total>") { $create_hyperlinks = $FALSE; } else { $create_hyperlinks = $TRUE; } #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g; $html_line = $metric_values[$i] . " "; if ($marker[$i] eq "*") { $current_function_name = "<b>" . $current_function_name . "</b>"; } $html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>"; if ($marker[$i] eq "*") { $html_line = "<br>" . $html_line; } elsif (($marker[$i] ne "*") and ($i == 0)) { $html_line = "<br>" . $html_line; } gp_message ("debugXL", $subr_name, "html_line = $html_line"); #------------------------------------------------------------------------------ # Find the index into "function_info" for this particular function. #------------------------------------------------------------------------------ $routine = $function_names[$i]; $current_address = $address_field[$i]; my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info); my $target_index = ${ $target_index_ref }; gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index"); #------------------------------------------------------------------------------ # TBD Do this once for each function and store the result. This is a saving # because functions may and typically will appear more than once. #------------------------------------------------------------------------------ my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"}; #------------------------------------------------------------------------------ # Add the links to the line. Make sure there is at least one space. #------------------------------------------------------------------------------ my $spaces = " "; for my $k (1 .. $spaces_left) { $spaces .= " "; } if ($create_hyperlinks) { $html_line .= $spaces; $html_line .= $function_info[$target_index]{"href_source"}; $html_line .= " "; $html_line .= $function_info[$target_index]{"href_disassembly"}; } push (@html_code_function_block, $html_line); } for my $lines (0 .. $#html_code_function_block) { gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]); } return (\@html_block_prologue, \@html_code_function_block); } #-- End of subroutine generate_html_function_blocks #------------------------------------------------------------------------------ # Generate the index.html file. #------------------------------------------------------------------------------ sub generate_index { my $subr_name = get_my_name (); my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, $metric_description_reversed_ref, $number_of_warnings_ref, $table_execution_stats_ref) = @_; my $outputdir = ${ $outputdir_ref }; my $html_first_metric_file = ${ $html_first_metric_file_ref }; my $summary_metrics = ${ $summary_metrics_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my %function_address_info = %{ $function_address_info_ref }; my @sort_fields = @{ $sort_fields_ref }; my @exp_dir_list = @{ $exp_dir_list_ref }; my %addressobjtextm = %{ $addressobjtextm_ref }; my %metric_description_reversed = %{ $metric_description_reversed_ref }; my $number_of_warnings = ${ $number_of_warnings_ref }; my @table_execution_stats = @{ $table_execution_stats_ref }; my @file_contents = (); my $acknowledgement; my @abs_path_exp_dirs = (); my $input_experiments; my $target_function; my $html_line; my $ftag; my $max_length = 0; my %html_source_functions = (); my $html_header; my @experiment_directories = (); my $html_acknowledgement; my $html_file_title; my $html_output_file; my $html_function_view; my $html_caller_callee_view; my $html_experiment_info; my $html_warnings_page; my $href_link; my $file_title; my $html_gprofng; my $html_end; my $max_length_metrics; my $page_title; my $size_text; my $position_text; my $ln; my $base; my $base_index_page; my $infile; my $outfile; my $rec; my $skip; my $callsize; my $dest; my $final_string; my @headers; my $header; my $sort_index; my $pc_address; my $anchor; my $directory_name; my $f2; my $f3; my $file; my $sline; my $src; my $srcfile_name; my $tmp1; my $tmp2; my $fullsize; my $regf2; my $trimsize; my $EIL; my $EEIL; my $AOBJ; my $RI; my $HDR; my $CALLER_CALLEE; my $NAME; my $SRC; my $TRIMMED; #------------------------------------------------------------------------------ # Add a forward slash to make it easier when creating file names. #------------------------------------------------------------------------------ $outputdir = append_forward_slash ($outputdir); gp_message ("debug", $subr_name, "outputdir = $outputdir"); my $LANG = $g_locale_settings{"LANG"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; $input_experiments = join (", ", @exp_dir_list); for my $i (0 .. $#exp_dir_list) { my $dir = get_basename ($exp_dir_list[$i]); push @abs_path_exp_dirs, $dir; } $input_experiments = join (", ", @abs_path_exp_dirs); gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); #------------------------------------------------------------------------------ # TBD: Pass in the values for $expr_name and $cmd #------------------------------------------------------------------------------ $html_file_title = "Main index page"; @experiment_directories = split (",", $input_experiments); $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html"; open (INDEX, ">", $html_output_file) or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); $page_title = "GPROFNG Performance Analysis"; $size_text = "h1"; $position_text = "center"; $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; $html_header = ${ create_html_header (\$html_file_title) }; print INDEX $html_header; print INDEX $html_gprofng; print INDEX "$_" for @g_html_experiment_stats; print INDEX "$_" for @table_execution_stats; $html_experiment_info = "<a href=\'"; $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html"; $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n"; $html_warnings_page = "<a href=\'"; $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html"; $html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n"; $html_function_view = "<a href=\'"; $html_function_view .= $html_first_metric_file; $html_function_view .= "\'><h3>Function View</h3></a>\n"; $html_caller_callee_view = "<a href=\'"; $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html"; $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n"; print INDEX "<br>\n"; ## print INDEX "<b>\n"; print INDEX $html_experiment_info; print INDEX $html_warnings_page;; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_function_view; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_caller_callee_view; ## print INDEX "</b>\n"; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_acknowledgement; print INDEX $html_end; close (INDEX); gp_message ("debug", $subr_name, "closed file $html_output_file"); return (0); } #-- End of subroutine generate_index #------------------------------------------------------------------------------ # Get all the metrics available # # (gp-display-text) metric_list # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Available metrics: # Exclusive Total CPU Time: e.%totalcpu # Inclusive Total CPU Time: i.%totalcpu # Exclusive CPU Cycles: e.+%cycles # Inclusive CPU Cycles: i.+%cycles # Exclusive Instructions Executed: e+%insts # Inclusive Instructions Executed: i+%insts # Exclusive Last-Level Cache Misses: e+%llm # Inclusive Last-Level Cache Misses: i+%llm # Exclusive Instructions Per Cycle: e+IPC # Inclusive Instructions Per Cycle: i+IPC # Exclusive Cycles Per Instruction: e+CPI # Inclusive Cycles Per Instruction: i+CPI # Size: size # PC Address: address # Name: name #------------------------------------------------------------------------------ sub get_all_the_metrics { my $subr_name = get_my_name (); my ($experiments_ref, $outputdir_ref) = @_; my $experiments = ${ $experiments_ref }; my $outputdir = ${ $outputdir_ref }; my $ignore_value; my $gp_functions_cmd; my $gp_display_text_cmd; my $metrics_output_file = $outputdir . "metrics-all"; my $result_file = $outputdir . $g_gp_output_file; my $gp_error_file = $outputdir . $g_gp_error_logfile; my $script_file_metrics = $outputdir . "script-metrics"; my @metrics_data = (); open (SCRIPT_METRICS, ">", $script_file_metrics) or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing"); print SCRIPT_METRICS "# outfile $metrics_output_file\n"; print SCRIPT_METRICS "outfile $metrics_output_file\n"; print SCRIPT_METRICS "# metric_list\n"; print SCRIPT_METRICS "metric_list\n"; close (SCRIPT_METRICS); $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments"; gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics"); $gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file"; gp_message ("debug", $subr_name, "cmd = $gp_display_text_cmd"); my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } open (METRICS_INFO, "<", $metrics_output_file) or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading"); #------------------------------------------------------------------------------ # Read the input file into memory. #------------------------------------------------------------------------------ chomp (@metrics_data = <METRICS_INFO>); gp_message ("debug", $subr_name, "read all contents of file $metrics_output_file into memory"); gp_message ("debug", $subr_name, "\$#metrics_data = $#metrics_data"); my $input_line; my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)'; my $split_line_regex = '(.*): (.*)'; my $empty_line_regex = '^\s*$'; my @metric_list_all = (); for (my $line_no=0; $line_no <= $#metrics_data; $line_no++) { $input_line = $metrics_data[$line_no]; ## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/)))) if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) ) { if ($input_line =~ /$split_line_regex/) { #------------------------------------------------------------------------------ # Remove the percentages. #------------------------------------------------------------------------------ my $metric_definition = $2; $metric_definition =~ s/\%//g; gp_message ("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition"); push (@metric_list_all, $metric_definition); } } } gp_message ("debug", $subr_name, "\@metric_list_all = @metric_list_all"); my $final_list = join (":", @metric_list_all); gp_message ("debug", $subr_name, "final_list = $final_list"); close (METRICS_INFO); return (\$final_list); } #-- End of subroutine get_all_the_metrics #------------------------------------------------------------------------------ # A simple function to return the basename using fileparse. To keep things # simple, a suffixlist is not supported. In case this is needed, use the # fileparse function directly. #------------------------------------------------------------------------------ sub get_basename { my ($full_name) = @_; my $ignore_value_1; my $ignore_value_2; my $basename_value; ($basename_value, $ignore_value_1, $ignore_value_2) = fileparse ($full_name); return ($basename_value); } #-- End of subroutine get_basename #------------------------------------------------------------------------------ # Get the details on the experiments and store these in a file. Each # experiment has its own file. This makes the processing easier. #------------------------------------------------------------------------------ sub get_experiment_info { my $subr_name = get_my_name (); my ($outputdir_ref, $exp_dir_list_ref) = @_; my $outputdir = ${ $outputdir_ref }; my @exp_dir_list = @{ $exp_dir_list_ref }; my $cmd_output; my $current_slot; my $error_code; my $exp_info_file; my @exp_info = (); my @experiment_data = (); my $gp_error_file; my $gp_display_text_cmd; my $gp_functions_cmd; my $gp_log_file; my $ignore_value; my $overview_file; my $result_file; my $script_file; my $the_experiments; $the_experiments = join (" ", @exp_dir_list); $script_file = $outputdir . "gp-info-exp.script"; $exp_info_file = $outputdir . "gp-info-exp-list.out"; $overview_file = $outputdir . "gp-overview.out"; $gp_log_file = $outputdir . $g_gp_output_file; $gp_error_file = $outputdir . $g_gp_error_logfile; open (SCRIPT_EXPERIMENT_INFO, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); #------------------------------------------------------------------------------ # Attributed User CPU Time=a.user : for calltree - see P37 in manual #------------------------------------------------------------------------------ print SCRIPT_EXPERIMENT_INFO "# compare on\n"; print SCRIPT_EXPERIMENT_INFO "compare on\n"; print SCRIPT_EXPERIMENT_INFO "# outfile $exp_info_file\n"; print SCRIPT_EXPERIMENT_INFO "outfile $exp_info_file\n"; print SCRIPT_EXPERIMENT_INFO "# exp_list\n"; print SCRIPT_EXPERIMENT_INFO "exp_list\n"; print SCRIPT_EXPERIMENT_INFO "# outfile $overview_file\n"; print SCRIPT_EXPERIMENT_INFO "outfile $overview_file\n"; print SCRIPT_EXPERIMENT_INFO "# overview\n"; print SCRIPT_EXPERIMENT_INFO "overview\n"; close SCRIPT_EXPERIMENT_INFO; $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information"); $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } #------------------------------------------------------------------------------- # The first file has the following format: # # ID Sel PID Experiment # == === ======= ====================================================== # 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er # 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er #------------------------------------------------------------------------------- open (EXP_INFO, "<", $exp_info_file) or die ("$subr_name - unable to open file $exp_info_file for reading '$!'"); gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading"); chomp (@exp_info = <EXP_INFO>); #------------------------------------------------------------------------------- # TBD - Check for the groups to exist below: #------------------------------------------------------------------------------- $current_slot = 0; for my $i (0 .. $#exp_info) { my $input_line = $exp_info[$i]; gp_message ("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]"); if ($input_line =~ /^\s*(\d+)\s+(.+)/) { my $exp_id = $1; my $remainder = $2; $experiment_data[$current_slot]{"exp_id"} = $exp_id; $experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out"; gp_message ("debug", $subr_name, $i . " " . $exp_id . " " . $remainder); if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/) { my $exp_name = $3; $experiment_data[$current_slot]{"exp_name_full"} = $exp_name; $experiment_data[$current_slot]{"exp_name_short"} = get_basename ($exp_name); $current_slot++; gp_message ("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3); } else { my $msg = "remainder = $remainder has an unexpected format"; gp_message ("assertion", $subr_name, $msg); } } } #------------------------------------------------------------------------------- # The experiment IDs and names are known. We can now generate the info for # each individual experiment. #------------------------------------------------------------------------------- $gp_log_file = $outputdir . $g_gp_output_file; $gp_error_file = $outputdir . $g_gp_error_logfile; $script_file = $outputdir . "gp-details-exp.script"; open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); for my $i (sort keys @experiment_data) { my $exp_id = $experiment_data[$i]{"exp_id"}; $result_file = $experiment_data[$i]{"exp_data_file"}; # statistics # header print SCRIPT_EXPERIMENT_DETAILS "# outfile " . $result_file . "\n"; print SCRIPT_EXPERIMENT_DETAILS "outfile " . $result_file . "\n"; print SCRIPT_EXPERIMENT_DETAILS "# header " . $exp_id . "\n"; print SCRIPT_EXPERIMENT_DETAILS "header " . $exp_id . "\n"; print SCRIPT_EXPERIMENT_DETAILS "# statistics " . $exp_id . "\n"; print SCRIPT_EXPERIMENT_DETAILS "statistics " . $exp_id . "\n"; } close (SCRIPT_EXPERIMENT_DETAILS); $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment details"); $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) #------------------------------------------------------------------------------- # This is unlikely to happen, but you never know. #------------------------------------------------------------------------------- { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); } return (\@experiment_data); } #-- End of subroutine get_experiment_info #------------------------------------------------------------------------------ # This subroutine returns a string of the type "size=<n>", where <n> is the # size of the file passed in. If n > 1024, a unit is appended. #------------------------------------------------------------------------------ sub getfilesize { my $subr_name = get_my_name (); my ($filename) = @_; my $size; my $file_stat; if (not -e $filename) { #------------------------------------------------------------------------------ # The return value is used in the caller. This is why we return the empty # string in case the file does not exist. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "filename = $filename not found"); return (""); } else { $file_stat = stat ($filename); $size = $file_stat->size; gp_message ("debug", $subr_name, "filename = $filename"); gp_message ("debug", $subr_name, "size = $size"); if ($size > 1024) { if ($size > 1024*1024) { $size = $size/1024/1024; $size =~ s/\..*//; $size = $size."MB"; } else { $size = $size/1024; $size =~ s/\..*//; $size = $size."KB"; } } else { $size=$size." bytes"; } gp_message ("debug", $subr_name, "size = $size title=\"$size\""); return ("title=\"$size\""); } } #-- End of subroutine getfilesize #------------------------------------------------------------------------------ # Parse the fsummary output and for all functions, store all the information # found in "function_info". In addition to this, several derived structures # are stored as well, making this structure a "onestop" place to get all the # info that is needed. #------------------------------------------------------------------------------ sub get_function_info { my $subr_name = get_my_name (); my ($FSUMMARY_FILE) = @_; #------------------------------------------------------------------------------ # The regex section. #------------------------------------------------------------------------------ my $white_space_regex = '\s*'; my @function_info = (); my %function_address_and_index = (); my %LINUX_vDSO = (); my %function_view_structure = (); my %addressobjtextm = (); #------------------------------------------------------------------------------ # TBD: This structure is no longer used and most likely can be removed. #------------------------------------------------------------------------------ my %functions_index = (); # TBD: check my $full_address_field; my %source_files = (); my $i; my $line; my $routine_flag; my $value; my $whatever; my $df_flag; my $address_decimal; my $routine; my $num_source_files = 0; my $number_of_functions = 0; my $number_of_unique_functions = 0; my $number_of_non_unique_functions = 0; #------------------------------------------------------------------------------ # Open the file generated using the -fsummary option. #------------------------------------------------------------------------------ open (FSUMMARY_FILE, "<", $FSUMMARY_FILE) or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $FSUMMARY_FILE for reading"); #------------------------------------------------------------------------------ # This is the typical structure of the fsummary output: # # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Functions sorted by metric: Exclusive Total CPU Time # # <Total> # Exclusive Total CPU Time: 11.538 (100.0%) # Inclusive Total CPU Time: 11.538 (100.0%) # Size: 0 # PC Address: 1:0x00000000 # Source File: (unknown) # Object File: (unknown) # Load Object: <Total> # Mangled Name: # Aliases: # # a_function_name # Exclusive Total CPU Time: 4.003 ( 34.7%) # Inclusive Total CPU Time: 4.003 ( 34.7%) # Size: 715 # PC Address: 2:0x00006c61 # Source File: <absolute path to source file> # Object File: <object filename> # Load Object: <executable name> # Mangled Name: # Aliases: # # The previous block is repeated for every function. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Skip the header. The header is defined to end with a blank line. #------------------------------------------------------------------------------ while (<FSUMMARY_FILE>) { $line = $_; chomp ($line); if ($line =~ /^\s*$/) { last; } } #------------------------------------------------------------------------------ # Process the remaining blocks. Note that the first line should be <Total>, # but this is currently not checked. #------------------------------------------------------------------------------ $i = 0; $routine_flag = $TRUE; while (<FSUMMARY_FILE>) { $line = $_; chomp ($line); gp_message ("debugXL", $subr_name, "line = $line"); if ($line =~ /^\s*$/) #------------------------------------------------------------------------------ # Blank line. #------------------------------------------------------------------------------ { $routine_flag = $TRUE; $df_flag = 0; #------------------------------------------------------------------------------ # Linux vDSO exception # # TBD: Check if still relevant. #------------------------------------------------------------------------------ if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS") { $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"}; } $i++; next; } if ($routine_flag) #------------------------------------------------------------------------------ # Should be the first line after the blank line. #------------------------------------------------------------------------------ { $routine = $line; push (@{ $g_map_function_to_index{$routine} }, $i); gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}"); #------------------------------------------------------------------------------ # In a later parsing phase we need to know how many fields there are in a # function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that # may show up in a function list. # # Here we determine the number of fields and store it. #------------------------------------------------------------------------------ my @fields_in_name = split (" ", $routine); $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name); #------------------------------------------------------------------------------ # This name may change if the function has multiple occurrences, but in any # case, at the end of this routine this component has the final name to be # used. #------------------------------------------------------------------------------ $function_info[$i]{"alt_name"} = $routine; if (not exists ($g_function_occurrences{$routine})) { gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist"); $function_info[$i]{"routine"} = $routine; $g_function_occurrences{$routine} = 1; gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}"); } else { gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already"); $function_info[$i]{"routine"} = $routine; $g_function_occurrences{$routine} += 1; if (not exists ($g_multi_count_function{$routine})) { $g_multi_count_function{$routine} = $TRUE; } my $msg = "g_function_occurrences{$routine} = " . $g_function_occurrences{$routine}; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # New: used when generating the index. #------------------------------------------------------------------------------ $function_info[$i]{"function length"} = length ($routine); $function_info[$i]{"tag_id"} = create_function_tag ($i); if (not exists ($g_function_tag_id{$routine})) { $g_function_tag_id{$routine} = create_function_tag ($i); } else { #------------------------------------------------------------------------------ ## TBD HACK!!! CHECK!!!!! #------------------------------------------------------------------------------ $g_function_tag_id{$routine} = $i; } $routine_flag = $FALSE; gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"}); #------------------------------------------------------------------------------ # The $functions_index hash contains an array. After an initial assignment, # other values that have been found are pushed onto the arrays. #------------------------------------------------------------------------------ if (not exists ($functions_index{$routine})) { $functions_index{$routine} = [$i]; } else { #------------------------------------------------------------------------------ # Add the array index to the list #------------------------------------------------------------------------------ push (@{$functions_index{$routine}}, $i); } next; } #------------------------------------------------------------------------------ # Expected format of an input line: # Exclusive Total CPU Time: 4.003 ( 34.7%) # or: # Source File: <absolute_path>/name_of_source_file #------------------------------------------------------------------------------ $line =~ s/^\s+//; my @input_fields = split (":", $line); my $no_of_elements = scalar (@input_fields); gp_message ("debugXL", $subr_name, "#input_fields = $#input_fields"); gp_message ("debugXL", $subr_name, "no_of_elements = $no_of_elements"); gp_message ("debugXL", $subr_name, "input_fields[0] = $input_fields[0]"); if ($no_of_elements == 1) { $whatever = $input_fields[0]; $value = ""; } elsif ($no_of_elements == 2) { #------------------------------------------------------------------------------ # Note that value may consist of multiple fields (e.g. 1.651 ( 95.4%)). #------------------------------------------------------------------------------ $whatever = $input_fields[0]; $value = $input_fields[1]; } elsif ($no_of_elements == 3) { #------------------------------------------------------------------------------ # Assumption: must be an address field. Restore the second colon. #------------------------------------------------------------------------------ $whatever = $input_fields[0]; $value = $input_fields[1] . ":" . $input_fields[2]; } else { my $msg = "unexpected: number of fields = " . $no_of_elements; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Remove any leading whitespace characters. #------------------------------------------------------------------------------ $value =~ s/$white_space_regex//; gp_message ("debugXL", $subr_name, "whatever = $whatever value = $value"); $function_info[$i]{$whatever} = $value; #------------------------------------------------------------------------------ # TBD: Seems to be not used anymore and can most likely be removed. Check this. #------------------------------------------------------------------------------ if ($whatever =~ /Source File/) { if (!exists ($source_files{$value})) { $source_files{$value} = $TRUE; $num_source_files++; } } if ($whatever =~ /PC Address/) { my $segment; my $offset; #------------------------------------------------------------------------------ # The format of the address is assumed to be the following 2:0x000070a8 # Note that the regex is pretty wide. This is from the original code and # could be made more specific: # if ($value =~ /\s*(\S+):(\S+)/) #------------------------------------------------------------------------------ # if ($value =~ /\s*(\S+):(\S+)/) if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/) { $segment = $1; $offset = $2; #------------------------------------------------------------------------------ # Convert to a base 10 number #------------------------------------------------------------------------------ $address_decimal = bigint::hex ($offset); # decimal #------------------------------------------------------------------------------ # Construct the address field. Note that we use the hex address here. #------------------------------------------------------------------------------ $full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280 $function_info[$i]{"addressobj"} = $address_decimal; $function_info[$i]{"addressobjtext"} = $full_address_field; $addressobjtextm{$full_address_field} = $i; # $RI } if (not exists ($function_address_and_index{$routine}{$value})) { $function_address_and_index{$routine}{$value} = $i; my $msg = "function_address_and_index{$routine}{$value} = " . $function_address_and_index{$routine}{$value}; gp_message ("debugXL", $subr_name, $msg); } else { gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address"); } $number_of_functions++; } } close (FSUMMARY_FILE); #------------------------------------------------------------------------------ # For every function in the function overview, set up an html structure with # the various hyperlinks. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "augment function_info with alt_name"); my $target_function; my $html_line; my $ftag; my $routine_length; my %html_source_functions = (); for my $i (keys @function_info) { $target_function = $function_info[$i]{"routine"}; gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function"); my $href_link; ## $href_link = "<a href=\'file." . $i . ".src.new.html#"; $href_link = "<a href=\'file." . $i . "."; $href_link .= $g_html_base_file_name{"source"}; $href_link .= ".html#"; $href_link .= $function_info[$i]{"tag_id"}; $href_link .= "\'>source</a>"; $function_info[$i]{"href_source"} = $href_link; $href_link = "<a href=\'file." . $i . "."; $href_link .= $g_html_base_file_name{"disassembly"}; $href_link .= ".html#"; $href_link .= $function_info[$i]{"tag_id"}; $href_link .= "\'>disassembly</a>"; $function_info[$i]{"href_disassembly"} = $href_link; $href_link = "<a href=\'"; $href_link .= $g_html_base_file_name{"caller_callee"}; $href_link .= ".html#"; $href_link .= $function_info[$i]{"tag_id"}; $href_link .= "\'>caller-callee</a>"; $function_info[$i]{"href_caller_callee"} = $href_link; gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}"); if ($g_function_occurrences{$target_function} > 1) { #------------------------------------------------------------------------------ # In case a function occurs more than one time in the function overview, we # add the load object and address offset info to make it unique. # # This forces us to update some entries in function_info too. #------------------------------------------------------------------------------ my $loadobj = $function_info[$i]{"Load Object"}; my $address_field = $function_info[$i]{"addressobjtext"}; my $address_offset; #------------------------------------------------------------------------------ # The address field has the following format: @<n>:<address_offset> # We only care about the address offset. #------------------------------------------------------------------------------ if ($address_field =~ /(^@\d*:*)(.+)/) { $address_offset = $2; } else { my $msg = "failed to extract the address offset from $address_field - use the full field"; gp_message ("warning", $subr_name, $msg); $address_offset = $address_field; } my $exe = get_basename ($loadobj); my $extra_field = " (<" . $exe . " $address_offset" .">)"; ### $target_function .= $extra_field; $function_info[$i]{"alt_name"} = $target_function . $extra_field; gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"}); #------------------------------------------------------------------------------ # Store the length of the function name and get the tag id. #------------------------------------------------------------------------------ $function_info[$i]{"function length"} = length ($target_function . $extra_field); $function_info[$i]{"tag_id"} = create_function_tag ($i); gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}"); gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}"); gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}"); } } gp_message ("debug", $subr_name, "augment function_info with alt_name completed"); #------------------------------------------------------------------------------ # Compute the maximum function name length. # # The maximum length is stored in %function_view_structure. #------------------------------------------------------------------------------ my $max_function_length = 0; for my $i (0 .. $#function_info) { $max_function_length = max ($max_function_length, $function_info[$i]{"function length"}); gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"}); } #------------------------------------------------------------------------------ # Define the name of the table and take the length into account, since it may # be longer than the function name(s). #------------------------------------------------------------------------------ $function_view_structure{"table name"} = "Function name"; $max_function_length = max ($max_function_length, length ($function_view_structure{"table name"})); $function_view_structure{"max function length"} = $max_function_length; #------------------------------------------------------------------------------ # Core loop that generates an HTML line for each function. This line is # stored in function_info. #------------------------------------------------------------------------------ my $top_of_table = $FALSE; for my $i (keys @function_info) { my $new_target_function; if (defined ($function_info[$i]{"alt_name"})) { $target_function = $function_info[$i]{"alt_name"}; gp_message ("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); } else { my $msg = "function_info[$i]{\"alt_name\"} is not defined"; gp_message ("assertion", $subr_name, $msg); } my $function_length = $function_info[$i]{"function length"}; my $number_of_blanks = $function_view_structure{"max function length"} - $function_length; my $spaces = " "; for my $i (1 .. $number_of_blanks) { $spaces .= " "; } if ($target_function eq "<Total>") #------------------------------------------------------------------------------ # <Total> is a pseudo function and there is no source, or disassembly for it. # We could add a link to the caller-callee part, but this is currently not # done. #------------------------------------------------------------------------------ { $top_of_table = $TRUE; $html_line = " <b><Total></b>"; } else { #------------------------------------------------------------------------------ # Add the * symbol as a marker in case the same function occurs multiple times. # Otherwise insert a space. #------------------------------------------------------------------------------ my $base_function_name = $function_info[$i]{"routine"}; if (exists ($g_function_occurrences{$base_function_name})) { if ($g_function_occurrences{$base_function_name} > 1) { $new_target_function = "*" . $target_function; } else { $new_target_function = " " . $target_function; } } else { my $msg = "g_function_occurrences{$base_function_name} does not exist"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Create the block with the function name, in boldface, plus the links to the # source, disassembly and caller-callee views. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g; $html_line = "<b>$new_target_function</b>" . $spaces; $html_line .= $function_info[$i]{"href_source"} . " "; $html_line .= $function_info[$i]{"href_disassembly"} . " "; $html_line .= $function_info[$i]{"href_caller_callee"}; } gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line"); $html_source_functions{$target_function} = $html_line; #------------------------------------------------------------------------------ # TBD: In the future we want to re-use this block elsewhere. #------------------------------------------------------------------------------ $function_info[$i]{"html function block"} = $html_line; } for my $i (keys %html_source_functions) { gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); } for my $i (keys @function_info) { gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"}); } #------------------------------------------------------------------------------ # Print the key data structure %function_info. This is a nested hash. #------------------------------------------------------------------------------ for my $i (0 .. $#function_info) { for my $role (sort keys %{ $function_info[$i] }) { gp_message ("debug", $subr_name, "on return: function_info[$i]{$role} = $function_info[$i]{$role}"); } } #------------------------------------------------------------------------------ # Print the data structure %function_address_and_index. This is a nested hash. #------------------------------------------------------------------------------ for my $F (keys %function_address_and_index) { 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}"); } } #------------------------------------------------------------------------------ # Print the data structure %functions_index. This is a hash with an arrray. #------------------------------------------------------------------------------ for my $F (keys %functions_index) { gp_message ("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }"); # alt code for my $i (0 .. $#{ $functions_index{$F} } ) # alt code { # alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]"); # alt code } } #------------------------------------------------------------------------------ # Print the data structure %function_view_structure. This is a hash. #------------------------------------------------------------------------------ for my $F (keys %function_view_structure) { gp_message ("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}"); } #------------------------------------------------------------------------------ # Print the data structure %g_function_occurrences and use this structure to # gather statistics about the functions. # # TBD: add this info to the experiment data overview. #------------------------------------------------------------------------------ $number_of_unique_functions = 0; $number_of_non_unique_functions = 0; for my $F (keys %g_function_occurrences) { gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}"); if ($g_function_occurrences{$F} == 1) { $number_of_unique_functions++; } else { $number_of_non_unique_functions++; } } for my $i (keys %g_map_function_to_index) { my $n = scalar (@{ $g_map_function_to_index{$i} }); gp_message ("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }"); } #------------------------------------------------------------------------------ # TBD: Include in experiment data. Include names with multiple occurrences. #------------------------------------------------------------------------------ my $msg; $msg = "Number of source files : " . $num_source_files; gp_message ("debug", $subr_name, $msg); $msg = "Total number of functions: $number_of_functions"; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions functions with a unique name : " . $number_of_unique_functions; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions functions with more than one occurrence : " . $number_of_non_unique_functions; gp_message ("debug", $subr_name, $msg); my $multi_occurrences = $number_of_functions - $number_of_unique_functions; $msg = "Total number of multiple occurences of the same function name : " . $multi_occurrences; gp_message ("debug", $subr_name, $msg); return (\@function_info, \%function_address_and_index, \%addressobjtextm, \%LINUX_vDSO, \%function_view_structure); } #-- End of subroutine get_function_info #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub get_hdr_info { my $subr_name = get_my_name (); my ($outputdir, $file) = @_; state $first_call = $TRUE; my $ASORTFILE; my @HDR; my $HDR; my $metric; my $line; my $ignore_directory; my $ignore_suffix; my $number_of_header_lines; #------------------------------------------------------------------------------ # Add a "/" to simplify the construction of path names in the remainder. #------------------------------------------------------------------------------ $outputdir = append_forward_slash ($outputdir); # Could get more header info from # <metric>[e.bit_fcount].sort.func file - etc. gp_message ("debug", $subr_name, "input file->$file<-"); #----------------------------------------------- if ($file eq $outputdir."calls.sort.func") { $ASORTFILE=$outputdir."calls"; $metric = "calls" } elsif ($file eq $outputdir."calltree.sort.func") { $ASORTFILE=$outputdir."calltree"; $metric = "calltree" } elsif ($file eq $outputdir."functions.sort.func") { $ASORTFILE=$outputdir."functions.func"; $metric = "functions"; } else { $ASORTFILE = $file; # $metric = basename ($file,".sort.func"); ($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func"); gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix"); } gp_message ("debug", $subr_name, "file = $file metric = $metric"); open (ASORTFILE,"<", $ASORTFILE) or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading"); $number_of_header_lines = 0; while (<ASORTFILE>) { $line =$_; chomp ($line); if ($line =~ /^Current/) { next; } if ($line =~ /^Functions/) { next; } if ($line =~ /^Callers/) { next; } if ($line =~ /^\s*$/) { next; } if (!($line =~ /^\s*\d/)) { $HDR[$number_of_header_lines] = $line; $number_of_header_lines++; next; } last; } close (ASORTFILE); #------------------------------------------------------------------------------- # Ruud - Fixed a bug. The output should not be appended, but overwritten. # open (HI,">>$OUTPUTDIR"."hdrinfo"); #------------------------------------------------------------------------------- my $outfile = $outputdir."hdrinfo"; if ($first_call) { $first_call = $FALSE; open (HI ,">", $outfile) or die ("$subr_name - unable to open file $outfile for writing: '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); } else { open (HI ,">>", $outfile) or die ("$subr_name - unable to open file $outfile in append mode: '$!'"); gp_message ("debug", $subr_name, "opened file $outfile in append mode"); } print HI "\#$metric hdrlines=$number_of_header_lines\n"; my $len = 0; for $HDR (@HDR) { print HI "$HDR\n"; gp_message ("debugXL", $subr_name, "HDR = $HDR\n"); } close (HI); if ($first_call) { gp_message ("debug", $subr_name, "wrote file $outfile"); } else { gp_message ("debug", $subr_name, "updated file $outfile"); } #----------------------------------------------- } #-- End of subroutine get_hdr_info #------------------------------------------------------------------------------ # Get the home directory and the location(s) of the configuration file on the # current system. #------------------------------------------------------------------------------ sub get_home_dir_and_rc_path { my $subr_name = get_my_name (); my ($rc_file_name) = @_; my @rc_file_paths; my $target_cmd; my $home_dir; my $error_code; $target_cmd = $g_mapped_cmds{"printenv"} . " HOME"; ($error_code, $home_dir) = execute_system_cmd ($target_cmd); if ($error_code != 0) { my $msg = "cannot find a setting for HOME - please set this"; gp_message ("assertion", $subr_name, $msg); } else #------------------------------------------------------------------------------ # The home directory is known and we can define the locations for the # configuration file. #------------------------------------------------------------------------------ { @rc_file_paths = (".", "$home_dir"); } gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths"); return ($home_dir, \@rc_file_paths); } #-- End of subroutine get_home_dir_and_rc_path #------------------------------------------------------------------------------ # This subroutine generates a list with the hot functions. #------------------------------------------------------------------------------ sub get_hot_functions { my $subr_name = get_my_name (); my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my $cmd_output; my $error_code; my $expr_name; my $first_metric; my $gp_display_text_cmd; my $ignore_value; my @sort_fields = (); $expr_name = join (" ", @exp_dir_list); gp_message ("debug", $subr_name, "expr_name = $expr_name"); my $outputdir = append_forward_slash ($input_string); my $script_file = $outputdir."gp-fsummary.script"; my $outfile = $outputdir."gp-fsummary.out"; my $result_file = $outputdir."gp-fsummary.stderr"; my $gp_error_file = $outputdir.$g_gp_error_logfile; @sort_fields = split (":", $summary_metrics); #------------------------------------------------------------------------------ # This is extremely unlikely to happen, but if so, it is a fatal error. #------------------------------------------------------------------------------ my $number_of_elements = scalar (@sort_fields); gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements"); if ($number_of_elements == 0) { my $msg = "there are $number_of_elements in the metrics list"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Get the summary of the hot functions #------------------------------------------------------------------------------ open (SCRIPT, ">", $script_file) or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); gp_message ("debug", $subr_name, "opened script file $script_file for writing"); #------------------------------------------------------------------------------ # TBD: Check what this is about: # Attributed User CPU Time=a.user : for calltree - see P37 in manual #------------------------------------------------------------------------------ print SCRIPT "# limit 0\n"; print SCRIPT "limit 0\n"; print SCRIPT "# metrics $summary_metrics\n"; print SCRIPT "metrics $summary_metrics\n"; print SCRIPT "# thread_select all\n"; print SCRIPT "thread_select all\n"; #------------------------------------------------------------------------------ # Use first out of summary metrics as first (it doesn't matter which one) # $first_metric = (split /:/,$summary_metrics)[0]; #------------------------------------------------------------------------------ $first_metric = $sort_fields[0]; print SCRIPT "# outfile $outfile\n"; print SCRIPT "outfile $outfile\n"; print SCRIPT "# sort $first_metric\n"; print SCRIPT "sort $first_metric\n"; print SCRIPT "# fsummary\n"; print SCRIPT "fsummary\n"; close SCRIPT; my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name"; gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions"); $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", $subr_name, "execution terminated"); my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd"; gp_message ("abort", $subr_name, $msg); } return ($outfile,\@sort_fields); } #-- End of subroutine get_hot_functions #------------------------------------------------------------------------------ # For a given function name, return the index into "function_info". This # index gives access to all the meta data for the input function. #------------------------------------------------------------------------------ sub get_index_function_info { my $subr_name = get_my_name (); my ($routine_ref, $hex_address_ref, $function_info_ref) = @_; my $routine = ${ $routine_ref }; my $hex_address = ${ $hex_address_ref }; my @function_info = @{ $function_info_ref }; #------------------------------------------------------------------------------ # Check if this function has multiple occurrences. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "check for multiple occurrences"); my $current_address = $hex_address; my $alt_name = $routine; my $found_a_match; my $index_into_function_info; my $target_tag; if (not exists ($g_multi_count_function{$routine})) { #------------------------------------------------------------------------------ # There is only a single occurrence and it is straightforward to get the tag. #-------------------------------------------------------------------------- ## push (@final_function_names, $routine); if (exists ($g_map_function_to_index{$routine})) { $index_into_function_info = $g_map_function_to_index{$routine}[0]; } else { my $msg = "no entry for $routine in g_map_function_to_index"; gp_message ("assertion", $subr_name, $msg); } } else { #------------------------------------------------------------------------------ # The function name has more than one occurrence and we need to find the one # that matches with the address. #------------------------------------------------------------------------------ $found_a_match = $FALSE; gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); for my $ref (keys @{ $g_map_function_to_index{$routine} }) { my $ref_index = $g_map_function_to_index{$routine}[$ref]; my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); #------------------------------------------------------------------------------ # TBD: Do this substitution when storing "addressobjtext" in function_info. #------------------------------------------------------------------------------ $addr_offset =~ s/^@\d+://; gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); if ($addr_offset eq $current_address) { $found_a_match = $TRUE; $index_into_function_info = $ref_index; last; } } #------------------------------------------------------------------------------ # If there is no match, something has gone really wrong and we bail out. #------------------------------------------------------------------------------ if (not $found_a_match) { my $msg = "cannot find the mapping in function_info for function $routine"; gp_message ("assertion", $subr_name, $msg); } } return (\$index_into_function_info); } #-- End of subroutine get_index_function_info #------------------------------------------------------------------------------- # Get the setting for LANG, or assign a default if it is not set. #------------------------------------------------------------------------------- sub get_LANG_setting { my $subr_name = get_my_name (); my $error_code; my $lang_setting; my $target_cmd; my $command_string; my $LANG; $target_cmd = $g_mapped_cmds{"printenv"}; #------------------------------------------------------------------------------ # Use the printenv command to get the settings for LANG. #------------------------------------------------------------------------------ if ($target_cmd eq "road_to_nowhere") { $error_code = 1; } else { $command_string = $target_cmd . " LANG"; ($error_code, $lang_setting) = execute_system_cmd ($command_string); } if ($error_code == 0) { chomp ($lang_setting); $LANG = $lang_setting; } else { $LANG = $g_default_setting_lang; my $msg = "cannot find a setting for LANG - use a default setting"; gp_message ("warning", $subr_name, $msg); } return ($LANG); } #-- End of subroutine get_LANG_setting #------------------------------------------------------------------------------ # This subroutine gathers the basic information about the metrics. #------------------------------------------------------------------------------ sub get_metrics_data { my $subr_name = get_my_name (); my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my $cmd_options; my $cmd_output; my $error_code; my $expr_name; my $metrics_cmd; my $metrics_output; my $target_cmd; $expr_name = join (" ", @exp_dir_list); gp_message ("debug", $subr_name, "expr_name = $expr_name"); #------------------------------------------------------------------------------ # Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is # to get all the output in files $outfile1 and $outfile2. These are then # parsed. #------------------------------------------------------------------------------ $cmd_options = " -viewmode machine -compare off -thread_select all"; $cmd_options .= " -outfile $outfile2"; $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name"; $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file"; gp_message ("debug", $subr_name, "command used to gather the information:"); gp_message ("debug", $subr_name, $metrics_cmd); ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd); #------------------------------------------------------------------------------ # Error handling. Any error that occurred is fatal and execution # should be aborted by the caller. #------------------------------------------------------------------------------ if ($error_code == 0) { gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2"); } else { $target_cmd = $g_mapped_cmds{"cat"} . " $error_file"; ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); chomp ($cmd_output); gp_message ("error", $subr_name, "contents of file $error_file:"); gp_message ("error", $subr_name, $cmd_output); } return ($error_code); } #-- End of subroutine get_metrics_data #------------------------------------------------------------------------------ # Wrapper that returns the last part of the subroutine name. The assumption is # that the last part of the input name is of the form "aa::bb" or just "bb". #------------------------------------------------------------------------------ sub get_my_name { my $called_by = (caller (1))[3]; my @parts = split ("::", $called_by); return ($parts[$#parts]); ## my ($the_full_name_ref) = @_; ## my $the_full_name = ${ $the_full_name_ref }; ## my $last_part; #------------------------------------------------------------------------------ # If the regex below fails, use the full name." #------------------------------------------------------------------------------ ## $last_part = $the_full_name; #------------------------------------------------------------------------------ # Capture the last part if there are multiple parts separated by "::". #------------------------------------------------------------------------------ ## if ($the_full_name =~ /.*::(.+)$/) ## { ## if (defined ($1)) ## { ## $last_part = $1; ## } ## } ## return (\$last_part); } #-- End of subroutine get_my_name #------------------------------------------------------------------------------- # Determine the characteristics of the current system #------------------------------------------------------------------------------- sub get_system_config_info { #------------------------------------------------------------------------------ # The output from the "uname" command is used for this. Although not all of # these are currently used, we store all fields in separate variables. #------------------------------------------------------------------------------ # #------------------------------------------------------------------------------ # The options supported on uname from GNU coreutils 8.22: #------------------------------------------------------------------------------ # -a, --all print all information, in the following order, # except omit -p and -i if unknown: # -s, --kernel-name print the kernel name # -n, --nodename print the network node hostname # -r, --kernel-release print the kernel release # -v, --kernel-version print the kernel version # -m, --machine print the machine hardware name # -p, --processor print the processor type or "unknown" # -i, --hardware-platform print the hardware platform or "unknown" # -o, --operating-system print the operating system #------------------------------------------------------------------------------ # Sample output: # Linux ruudvan-vm-2-8-20200701 4.14.35-2025.400.8.el7uek.x86_64 #2 SMP Wed Aug 26 12:22:05 PDT 2020 x86_64 x86_64 x86_64 GNU/Linux #------------------------------------------------------------------------------ my $subr_name = get_my_name (); my $target_cmd; my $hostname_current; my $error_code; my $ignore_output; #------------------------------------------------------------------------------ # Test once if the command succeeds. This avoids we need to check every # specific # command below. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{uname}; ($error_code, $ignore_output) = execute_system_cmd ($target_cmd); if ($error_code != 0) #------------------------------------------------------------------------------- # This is unlikely to happen, but you never know. #------------------------------------------------------------------------------- { gp_message ("abort", $subr_name, "failure to execute the uname command"); } my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name); my $nodename = qx ($target_cmd -n); chomp ($nodename); my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release); my $kernel_version = qx ($target_cmd -v); chomp ($kernel_version); my $machine = qx ($target_cmd -m); chomp ($machine); my $processor = qx ($target_cmd -p); chomp ($processor); my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform); my $operating_system = qx ($target_cmd -o); chomp ($operating_system); $local_system_config{"kernel_name"} = $kernel_name; $local_system_config{"nodename"} = $nodename; $local_system_config{"kernel_release"} = $kernel_release; $local_system_config{"kernel_version"} = $kernel_version; $local_system_config{"machine"} = $machine; $local_system_config{"processor"} = $processor; $local_system_config{"hardware_platform"} = $hardware_platform; $local_system_config{"operating_system"} = $operating_system; gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:"); gp_message ("debug", $subr_name, "kernel_name = $kernel_name"); gp_message ("debug", $subr_name, "nodename = $nodename"); gp_message ("debug", $subr_name, "kernel_release = $kernel_release"); gp_message ("debug", $subr_name, "kernel_version = $kernel_version"); gp_message ("debug", $subr_name, "machine = $machine"); gp_message ("debug", $subr_name, "processor = $processor"); gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform"); gp_message ("debug", $subr_name, "operating_system = $operating_system"); #------------------------------------------------------------------------------ # Check if the system we are running on is supported. #------------------------------------------------------------------------------ my $is_supported = ${ check_support_for_processor (\$machine) }; if (not $is_supported) { gp_message ("error", $subr_name, "$machine is not supported"); exit (0); } #------------------------------------------------------------------------------ # The current hostname is used to compare against the hostname(s) found in the # experiment directories. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{hostname}; $hostname_current = qx ($target_cmd); chomp ($hostname_current); $error_code = ${^CHILD_ERROR_NATIVE}; if ($error_code == 0) { $local_system_config{"hostname_current"} = $hostname_current; } else #------------------------------------------------------------------------------- # This is unlikely to happen, but you never know. #------------------------------------------------------------------------------- { gp_message ("abort", $subr_name, "failure to execute the hostname command"); } for my $key (sort keys %local_system_config) { gp_message ("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}"); } return (0); } #-- End of subroutine get_system_config_info #------------------------------------------------------------------------------- # This subroutine prints a message. Several types of messages are supported. # In case the type is "abort", or "error", execution is terminated. # # Note that "debug", "warning", and "error" mode, the name of the calling # subroutine is truncated to 30 characters. In case the name is longer, # a warning message # is issued so you know this has happened. # # Note that we use lcfirst () and ucfirst () to enforce whether the first # character is printed in lower or uppercase. It is nothing else than a # convenience, but creates more consistency across messages. #------------------------------------------------------------------------------- sub gp_message { my $subr_name = get_my_name (); my ($action, $caller_name, $comment_line) = @_; #------------------------------------------------------------------------------- # The debugXL identifier is special. It is accepted, but otherwise ignored. # This allows to (temporarily) disable debug print statements, but keep them # around. #------------------------------------------------------------------------------- my %supported_identifiers = ( "verbose" => "[Verbose]", "debug" => "[Debug]", "error" => "[Error]", "warning" => "[Warning]", "abort" => "[Abort]", "assertion" => "[Assertion error]", "diag" => "", ); my $debug_size; my $identifier; my $fixed_size_name; my $string_limit = 30; my $strlen = length ($caller_name); my $trigger_debug = $FALSE; my $truncated_name; my $msg; if ($action =~ /debug\s*(.+)/) { if (defined ($1)) { my $orig_value = $1; $debug_size = lc ($1); if ($debug_size =~ /^s$|^m$|^l$|^xl$/) { if ($g_debug_size{$debug_size}) { #------------------------------------------------------------------------------- # All we need to know is whether a debug action is requested and whether the # size has been enabled. By setting $action to "debug", the code below is # simplified. Note that only using $trigger_debug below is actually sufficient. #------------------------------------------------------------------------------- $trigger_debug = $TRUE; } } else { die "$subr_name: debug size $orig_value is not supported"; } $action = "debug"; } } elsif ($action eq "debug") { $trigger_debug = $TRUE; } #------------------------------------------------------------------------------- # Catch any non-supported identifier. #------------------------------------------------------------------------------- if (defined ($supported_identifiers{$action})) { $identifier = $supported_identifiers{$action}; } else { die ("$subr_name - input error: $action is not supported"); } if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off")) { $trigger_debug = $FALSE; } #------------------------------------------------------------------------------- # Unconditionally buffer all warning messages. These are meant to be displayed # separately. #------------------------------------------------------------------------------- if ($action eq "warning") { push (@g_warning_messages, ucfirst ($comment_line)); } #------------------------------------------------------------------------------- # Quick return in several cases. Note that "debug", "verbose", "warning", and # "diag" messages are suppressed in quiet mode, but "error", "abort" and # "assertion" always pass. #------------------------------------------------------------------------------- if (( ($action eq "verbose") and (not $g_verbose)) or (($action eq "debug") and (not $trigger_debug)) or (($action eq "verbose") and ($g_quiet)) or (($action eq "debug") and ($g_quiet)) or (($action eq "warning") and (not $g_warnings)) or (($action eq "diag") and ($g_quiet))) { return (0); } #------------------------------------------------------------------------------- # In diag mode, just print the input line and nothing else. #------------------------------------------------------------------------------- if (( $action eq "debug") or ($action eq "abort") or ($action eq "warning") or ($action eq "assertion") or ($action eq "error")) { #------------------------------------------------------------------------------- # Construct the string to be printed. Include an identifier and the name of # the function. #------------------------------------------------------------------------------- if ($strlen > $string_limit) { $truncated_name = substr ($caller_name, 0, $string_limit); $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name); print "Warning in $subr_name - the name of the caller is: $caller_name\n"; print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n"; } else { $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name); } if (($action eq "error") or ($action eq "abort")) #------------------------------------------------------------------------------- # Enforce that the message starts with a lowercase symbol. Since these are # user errors, the name of the routine is not shown. The same for "abort". # If you want to display the routine name too, use an assertion. #------------------------------------------------------------------------------- { printf ("%-9s %s\n", $identifier, lcfirst ($comment_line)); } elsif ($action eq "assertion") #------------------------------------------------------------------------------- # Enforce that the message starts with a lowercase symbol. #------------------------------------------------------------------------------- { printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); } elsif (($action eq "debug") and ($trigger_debug)) #------------------------------------------------------------------------------- # Debug messages are printed "as is". Avoids issues when searching for them ;-) #------------------------------------------------------------------------------- { printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); } else #------------------------------------------------------------------------------- # Enforce that the message starts with a lowercase symbol. #------------------------------------------------------------------------------- { printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line)); } } elsif ($action eq "verbose") #------------------------------------------------------------------------------- # The first character in the verbose message is capatilized. #------------------------------------------------------------------------------- { printf ("%s\n", ucfirst ($comment_line)); } elsif ($action eq "diag") #------------------------------------------------------------------------------- # The diag messages are meant to be diagnostics. Only the comment line is # printed. #------------------------------------------------------------------------------- { printf ("%s\n", $comment_line); return (0); } #------------------------------------------------------------------------------- # Terminate execution in case the identifier is "abort". #------------------------------------------------------------------------------- if (($action eq "abort") or ($action eq "assertion")) { ## print "ABORT temporarily disabled for testing purposes\n"; exit (-1); } else { return (0); } } #-- End of subroutine gp_message #------------------------------------------------------------------------------ # Dynamically load the modules needed. Returns a list with the modules that # could not be loaded. #------------------------------------------------------------------------------ sub handle_module_availability { my $subr_name = get_my_name (); gp_message ("verbose", $subr_name, "Handling module requirements"); #------------------------------------------------------------------------------ # This is clunky at best, but there is a chicken egg problem here. For the # man page to be generated, the --help and --version options need to work, # but this part of the code only works if the "stat" function is available. # The "feature qw (state)" is required for the code to compile. # # TBD: Consider using global variables and to decouple parts of the option # handling. #; ## my @modules_used = ("feature", ## "File::stat", #------------------------------------------------------------------------------ my @modules_used = ( "List::Util", "Cwd", "File::Basename", "File::stat", "POSIX", "bigint", "bignum"); my @missing_modules = (); my $cmd; my $result; #------------------------------------------------------------------------------ # This loop checks for the availability of the modules and if so, imports # the module. # # The names of missing modules, if any, are stored and printed in the error # handling section below. #------------------------------------------------------------------------------ for my $i (0 .. $#modules_used) { my $m = $modules_used[$i]; if (eval "require $m;") { if ($m eq "feature") { $cmd = $m . "->import ( qw (state))"; } elsif ($m eq "List::Util") { $cmd = $m . "->import ( qw (min max))"; } 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); } } #------------------------------------------------------------------------------ # Count the number of missing modules. It is upon the caller to decide what # to do in case of errors. Currently, execution is aborted. #------------------------------------------------------------------------------ my $errors = scalar (@missing_modules); return (\$errors, \@missing_modules); } #-- End of subroutine handle_module_availability #------------------------------------------------------------------------------ # Generate the HTML with the experiment summary. #------------------------------------------------------------------------------ sub html_generate_exp_summary { my $subr_name = get_my_name (); my ($outputdir_ref, $experiment_data_ref) = @_; my $outputdir = ${ $outputdir_ref }; my @experiment_data = @{ $experiment_data_ref }; my $file_title; my $outfile; my $page_title; my $size_text; my $position_text; my $html_header; my $html_home; my $html_title_header; my $html_acknowledgement; my $html_end; my @html_exp_table_data = (); my $html_exp_table_data_ref; my @table_execution_stats = (); my $table_execution_stats_ref; gp_message ("debug", $subr_name, "outputdir = $outputdir"); $outputdir = append_forward_slash ($outputdir); gp_message ("debug", $subr_name, "outputdir = $outputdir"); $file_title = "Experiment information"; $page_title = "Experiment Information"; $size_text = "h2"; $position_text = "center"; $html_header = ${ create_html_header (\$file_title) }; $html_home = ${ generate_home_link ("right") }; $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html"; open (EXP_INFO, ">", $outfile) or die ("unable to open $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); print EXP_INFO $html_header; print EXP_INFO $html_home; print EXP_INFO $html_title_header; ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref); @html_exp_table_data = @{ $html_exp_table_data_ref }; @table_execution_stats = @{ $table_execution_stats_ref }; print EXP_INFO "$_" for @html_exp_table_data; ; ## print EXP_INFO "<pre>\n"; ## print EXP_INFO "$_\n" for @html_caller_callee; ## print EXP_INFO "</pre>\n"; #------------------------------------------------------------------------------- # Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------- $html_home = ${ generate_home_link ("left") }; $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; print EXP_INFO $html_home; print EXP_INFO "<br>\n"; print EXP_INFO $html_acknowledgement; print EXP_INFO $html_end; close (EXP_INFO); return (\@table_execution_stats); } #-- End of subroutine html_generate_exp_summary #------------------------------------------------------------------------------- # Generate the entries for the tables with the experiment info. #------------------------------------------------------------------------------- sub html_generate_table_data { my $subr_name = get_my_name (); my ($experiment_data_ref) = @_; my @experiment_data = (); my @html_exp_table_data = (); my $html_line; ## my $html_header_line; my $entry_name; my $key; my $size_text; my $position_text; my $title_table_1; my $title_table_2; my $title_table_3; my $title_table_summary; my $html_table_title; my @experiment_table_1_def = (); my @experiment_table_2_def = (); my @experiment_table_3_def = (); my @exp_table_summary_def = (); my @experiment_table_1 = (); my @experiment_table_2 = (); my @experiment_table_3 = (); my @exp_table_summary = (); my @exp_table_selection = (); @experiment_data = @{ $experiment_data_ref }; for my $i (sort keys @experiment_data) { for my $fields (sort keys %{ $experiment_data[$i] }) { gp_message ("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}"); } } $title_table_1 = "Target System Configuration"; $title_table_2 = "Experiment Statistics"; $title_table_3 = "Run Time Statistics"; $title_table_summary = "Main Statistics"; $size_text = "h3"; $position_text = "left"; push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"}; push @experiment_table_1_def, { name => "Hostname" , key => "hostname"}; push @experiment_table_1_def, { name => "Operating system", key => "OS"}; push @experiment_table_1_def, { name => "Architecture", key => "architecture"}; push @experiment_table_1_def, { name => "Page size", key => "page_size"}; push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"}; push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"}; push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"}; push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"}; push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; ## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"}; push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; ## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"}; push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"}; ## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"}; push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"}; push @exp_table_summary_def, { name => "Hostname" , key => "hostname"}; push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"}; $html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) }; push (@html_exp_table_data, $html_table_title); @experiment_table_1 = @{ create_table (\@experiment_data, \@experiment_table_1_def) }; push (@html_exp_table_data, @experiment_table_1); $html_table_title = ${ generate_a_header (\$title_table_2, \$size_text, \$position_text) }; push (@html_exp_table_data, $html_table_title); @experiment_table_2 = @{ create_table (\@experiment_data, \@experiment_table_2_def) }; push (@html_exp_table_data, @experiment_table_2); $html_table_title = ${ generate_a_header (\$title_table_3, \$size_text, \$position_text) }; push (@html_exp_table_data, $html_table_title); @experiment_table_3 = @{ create_table (\@experiment_data, \@experiment_table_3_def) }; push (@html_exp_table_data, @experiment_table_3); $html_table_title = ${ generate_a_header (\$title_table_summary, \$size_text, \$position_text) }; push (@exp_table_summary, $html_table_title); @exp_table_selection = @{ create_table (\@experiment_data, \@exp_table_summary_def) }; push (@exp_table_summary, @exp_table_selection); return (\@html_exp_table_data, \@exp_table_summary); } #-- End of subroutine html_generate_table_data #------------------------------------------------------------------------------ # Generate the HTML text to print in case a file is empty. #------------------------------------------------------------------------------ sub html_text_empty_file { my $subr_name = get_my_name (); my ($comment_ref, $error_file_ref) = @_; my $comment; my $error_file; my $error_message; my $file_title; my $html_end; my $html_header; my $html_home; my @html_empty_file = (); $comment = ${ $comment_ref }; $error_file = ${ $error_file_ref }; $file_title = "File is empty"; $html_header = ${ create_html_header (\$file_title) }; $html_end = ${ terminate_html_document () }; $html_home = ${ generate_home_link ("left") }; push (@html_empty_file, $html_header); $error_message = "<b>" . $comment . "</b>"; $error_message = set_background_color_string ($error_message, $g_html_color_scheme{"error_message"}); push (@html_empty_file, $error_message); if (not is_file_empty ($error_file)) { $error_message = "<p><em>Check file $error_file for more information</em></p>"; } push (@html_empty_file, $error_message); push (@html_empty_file, $html_home); push (@html_empty_file, "<br>"); push (@html_empty_file, $g_html_credits_line); push (@html_empty_file, $html_end); return (\@html_empty_file); } #-- End of subroutine html_text_empty_file #------------------------------------------------------------------------------ # This subroutine checks if a file is empty and returns $TRUE or $FALSE. #------------------------------------------------------------------------------ sub is_file_empty { my $subr_name = get_my_name (); my ($filename) = @_; my $size; my $file_stat; my $is_empty; chomp ($filename); if (not -e $filename) { #------------------------------------------------------------------------------ # The return value is used in the caller. This is why we return the empty # string in case the file does not exist. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "filename = $filename not found"); $is_empty = $TRUE; } else { $file_stat = stat ($filename); $size = $file_stat->size; $is_empty = ($size == 0) ? $TRUE : $FALSE; } gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty"); return ($is_empty); } #-- End of subroutine is_file_empty #------------------------------------------------------------------------------ # Check if a file is executable and return $TRUE or $FALSE. #------------------------------------------------------------------------------ sub is_file_executable { my $subr_name = get_my_name (); my ($filename) = @_; my $file_permissions; my $index_offset; my $is_executable; my $mode; my $number_of_bytes; my @permission_settings = (); my %permission_values = (); chomp ($filename); gp_message ("debug", $subr_name, "check if filename = $filename is executable"); if (not -e $filename) { #------------------------------------------------------------------------------ # The return value is used in the caller. This is why we return the empty # string in case the file does not exist. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "filename = $filename not found"); $is_executable = $FALSE; } else { $mode = stat ($filename)->mode; gp_message ("debugXL", $subr_name, "mode = $mode"); #------------------------------------------------------------------------------ # Get username. We currently do not do anything with this though and the # code is commented out. # # my $my_name = getlogin () || getpwuid($<) || "Kilroy";; # gp_message ("debug", $subr_name, "my_name = $my_name"); #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Convert file permissions to octal, split the individual numbers and store # the values for the respective users. #------------------------------------------------------------------------------ $file_permissions = sprintf("%o", $mode & 07777); @permission_settings = split (//, $file_permissions); $number_of_bytes = scalar (@permission_settings); gp_message ("debugXL", $subr_name, "file_permissions = $file_permissions"); gp_message ("debugXL", $subr_name, "permission_settings = @permission_settings"); gp_message ("debugXL", $subr_name, "number_of_settings = $number_of_bytes"); if ($number_of_bytes == 4) { $index_offset = 1; } elsif ($number_of_bytes == 3) { $index_offset = 0; } else { my $msg = "unexpected number of $number_of_bytes bytes " . "in permission settings: @permission_settings"; gp_message ("assertion", $subr_name, $msg); } $permission_values{user} = $permission_settings[$index_offset++]; $permission_values{group} = $permission_settings[$index_offset++]; $permission_values{other} = $permission_settings[$index_offset]; #------------------------------------------------------------------------------ # The executable bit should be set for user, group and other. If this fails # we mark the file as not executable. Note that this is gprofng specific. #------------------------------------------------------------------------------ $is_executable = $TRUE; for my $k (keys %permission_values) { my $msg = "permission_values{" . $k . "} = " . $permission_values{$k}; gp_message ("debugXL", $subr_name, $msg); if ($permission_values{$k} % 2 == 0) { $is_executable = $FALSE; last; } } } gp_message ("debug", $subr_name, "is_executable = $is_executable"); return ($is_executable); } #-- End of subroutine is_file_executable #------------------------------------------------------------------------------- # TBD. #------------------------------------------------------------------------------- sub name_regex { my $subr_name = get_my_name (); my ($metric_description_ref, $metrics, $field, $file) = @_; my %metric_description = %{ $metric_description_ref }; my @splitted_metrics; my $splitted_metrics; my $m; my $mf; my $nf; my $re; my $Xre; my $noPCfile; my @reported_metrics; my $reported_metrics; my $hdr_regex; my $hdr_href_regex; my $hdr_src_regex; my $new_metrics; my $pre; my $post; my $rat; my @moo = (); my $gp_metrics_file; my $gp_metrics_dir; my $suffix_not_used; my $is_calls = $FALSE; my $is_calltree = $FALSE; gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-"); #------------------------------------------------------------------------------- # According to https://perldoc.perl.org/File::Basename, both dirname and # basename are not reliable and fileparse () is recommended instead. # # Note that $gp_metrics_dir has a trailing "/". #------------------------------------------------------------------------------- ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC"); gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file"); gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); if ($gp_metrics_file eq "calls") { $is_calls = $TRUE; } if ($gp_metrics_file eq "calltree") { $is_calltree = $TRUE; } $gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC"; $gp_metrics_file = $gp_metrics_dir . $gp_metrics_file; gp_message ("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file"); open (GP_METRICS, "<", $gp_metrics_file) or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'"); gp_message ("debug", $subr_name, "opened file $gp_metrics_file for reading"); $new_metrics = $metrics; while (<GP_METRICS>) { $rat = $_; chomp ($rat); gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics"); #------------------------------------------------------------------------------- # Capture the string after "Current metrics:" and if it ends with ":name", # remove it. #------------------------------------------------------------------------------- if ($rat =~ /^\s*Current metrics:\s*(.*)$/) { $new_metrics = $1; if ($new_metrics =~ /^(.*):name$/) { $new_metrics = $1; } last; } } close (GP_METRICS); if ($is_calls or $is_calltree) { #------------------------------------------------------------------------------- # Remove any inclusive metrics from the list. #------------------------------------------------------------------------------- while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/) { $pre = $1; $post = $3; gp_message ("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post"); if (substr ($post,0,1) eq ":") { $post = substr ($post,1); } $new_metrics = $pre.$post; } } $metrics = $new_metrics; gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-"); #------------------------------------------------------------------------------- # Find the line starting with "address:" and strip this part away. #------------------------------------------------------------------------------- if ($metrics =~ /^address:(.*)/) { $reported_metrics = $1; #------------------------------------------------------------------------------- # Focus on the filename ending with "-PC". When found, strip this part away. #------------------------------------------------------------------------------- if ($file =~ /^(.*)-PC$/) { $noPCfile = $1; if ($noPCfile =~ /^(.*)functions.sort.func$/) { $noPCfile = $1."functions.func"; } push (@moo, "$reported_metrics\n"); } } #------------------------------------------------------------------------------- # Split the list into an array with the individual metrics. # # TBD: This should be done only once! #------------------------------------------------------------------------------- @reported_metrics = split (":", $reported_metrics); for my $i (@reported_metrics) { gp_message ("debugXL", $subr_name, "reported_metrics = $i"); } $hdr_regex = "^\\s*"; $hdr_href_regex = "^\\s*"; $hdr_src_regex = "^(\\s+|<i>\\s+)"; for my $m (@reported_metrics) { my $description = ${ retrieve_metric_description (\$m, \%metric_description) }; gp_message ("debugXL", $subr_name, "m = $m description = $description"); if (substr ($m,0,1) eq "e") { push (@moo,"$m:$description\n"); $hdr_regex .= "(Excl\\.\.*)"; $hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)"; $hdr_src_regex .= "(Excl\\.\.*)"; next; } if (substr ($m,0,1) eq "i") { push (@moo,"$m:$description\n"); $hdr_regex .= "(Incl\\.\.*)"; $hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)"; $hdr_src_regex .= "(Incl\\.\.*)"; next; } if (substr ($m,0,1) eq "a") { my $a; my $am; $a = $m; $a =~ s/^a/e/; $am = ${ retrieve_metric_description (\$a, \%metric_description) }; $am =~ s/Exclusive/Attributed/; push (@moo,"$m:$am\n"); $hdr_regex .= "(Attr\\.\.*)"; $hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)"; $hdr_src_regex .= "(Attr\\.\.*)";next; } } $hdr_regex .= "(Name\.*)"; $hdr_href_regex .= "(Name\.*)"; @splitted_metrics = split (":","$metrics"); $nf = scalar (@splitted_metrics); gp_message ("debug", $subr_name,"number of fields in $metrics -> $nf"); open (ZMETRICS, ">", "$noPCfile.metrics") or die ("Not able to open file $noPCfile.metrics for writing - '$!'"); gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing"); print ZMETRICS @moo; close (ZMETRICS); gp_message ("debug", $subr_name, "wrote file $noPCfile.metrics"); open (XREGEXP, ">", "$noPCfile.c.regex") or die ("Not able to open file $noPCfile.c.regex for writing - '$!'"); gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing"); print XREGEXP "\# Number of metric fields\n"; print XREGEXP "$nf\n"; print XREGEXP "\# Header regex\n"; print XREGEXP "$hdr_regex\n"; print XREGEXP "\# href Header regex\n"; print XREGEXP "$hdr_href_regex\n"; print XREGEXP "\# src Header regex\n"; print XREGEXP "$hdr_src_regex\n"; $mf = 1; #--------------------------------------------------------------------------- # Find the index of "field" in the metric list, plus one. #--------------------------------------------------------------------------- if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree")) { $mf = $nf + 1; } else { for my $candidate_metric (@splitted_metrics) { gp_message ("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf"); if ($candidate_metric eq $field) { last; } $mf++; } } gp_message ("debugXL", $subr_name, "Final value mf = $mf"); if ($mf == 1) { $re = "^\\s*(\\S+)"; # metric value } else { $re = "^\\s*\\S+"; } $Xre = "^\\s*(\\S+)"; $m = 2; while (--$nf) { if ($nf) { if ($m == $mf) { $re .= "\\s+(\\S+)"; # metric value } else { $re .= "\\s+\\S+"; } if ($nf != 1) { $Xre .= "\\s+(\\S+)"; } $m++; } } if ($field eq "calltree") { $re .= "\\s+.*\\+-(.*)"; # name $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?) } else { $re .= "\\s+(.*)"; # name $Xre .= "\\s+(.*)\$"; # name } print XREGEXP "\# Metrics and Name regex\n"; print XREGEXP "$Xre\n"; close (XREGEXP); gp_message ("debug", $subr_name, "wrote file $noPCfile.c.regex"); gp_message ("debugXL", $subr_name, "on return Xre = $Xre"); gp_message ("debugXL", $subr_name, "on return re = $re"); return ($re); } #-- End of subroutine name_regex #------------------------------------------------------------------------------- # TBD #------------------------------------------------------------------------------- sub nosrc { my $subr_name = get_my_name (); my ($input_string) = @_; my $directory_name = append_forward_slash ($input_string); my $LANG = $g_locale_settings{"LANG"}; my $result_file = $directory_name."no_source.html"; gp_message ("debug", $subr_name, "result_file = $result_file"); open (NS, ">", $result_file) or die ("$subr_name: cannot open file $result_file for writing - '$!'"); print NS "<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n". "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . "<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n"; print NS "<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font print NS "</pre>\n<pre>Output generated by $version_info</pre>\n"; print NS "</body></html>\n"; close (NS); return (0); } #-- End of subroutine nosrc #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ sub numerically { my $f1; my $f2; if ($a =~ /^([^\d]*)(\d+)/) { $f1 = int ($2); if ($b=~ /^([^\d]*)(\d+)/) { $f2 = int ($2); $f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1); } } else { return ($a <=> $b); } } #-- End of subroutine numerically #------------------------------------------------------------------------------ # Parse the user options. Also perform a basic check. More checks and also # some specific to the option will be performed after this subroutine. #------------------------------------------------------------------------------ sub parse_and_check_user_options { my $subr_name = get_my_name (); my ($no_of_args_ref, $option_list_ref) = @_; my $no_of_args = ${ $no_of_args_ref }; my @option_list = @{ $option_list_ref }; my @exp_dir_list; my $arg; my $calltree_value; my $debug_value; my $default_metrics_value; my $func_limit_value; my $found_exp_dir = $FALSE; my $ignore_metrics_value; my $ignore_value; my $message; my $outputdir_value; my $quiet_value; my $hp_value; my $valid; my $verbose_value; $no_of_args++; gp_message ("debug", $subr_name, "no_of_args = $no_of_args"); gp_message ("debug", $subr_name, "option_list = @option_list"); my $option_errors = 0; while (defined ($arg = shift @ARGV)) { gp_message ("debug", $subr_name, "parsing options arg = $arg"); gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV"); #------------------------------------------------------------------------------ # The gprofng driver adds this option. We need to get rid of it. #------------------------------------------------------------------------------ next if ($arg eq "--whoami=gprofng display html"); #------------------------------------------------------------------------------ # Parse the input options and check for the values to be valid. # # Valid values are stored in the main option table. # # TBD: The early check handles some of these already and the duplicates # can be removed. Be aware of some global settings though. #------------------------------------------------------------------------------ if ($arg eq "--version") { print_version_info (); exit (0); } elsif ($arg eq "--help") { $ignore_value = print_help_info (); exit (0); } elsif (($arg eq "-v") or ($arg eq "--verbose")) { $verbose_value = shift @ARGV; $valid = check_user_option ("verbose", $verbose_value); if (not $valid) { $option_errors++; } else { $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; } next; } elsif (($arg eq "-w") or ($arg eq "--warnings")) { my $warnings_value = shift @ARGV; $valid = check_user_option ("warnings", $warnings_value); if (not $valid) { $option_errors++; } else { $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; } next; } elsif (($arg eq "-d") or ($arg eq "--debug")) { $debug_value = shift @ARGV; $valid = check_user_option ("debug", $debug_value); if (not $valid) { $option_errors++; } else { #------------------------------------------------------------------------------ # This function internally converts the value to uppercase. #------------------------------------------------------------------------------ my $ignore_value = set_debug_size (\$debug_value); } next; } elsif (($arg eq "-q") or ($arg eq "--quiet")) { $quiet_value = shift @ARGV; $valid = check_user_option ("quiet", $quiet_value); if (not $valid) { $option_errors++; } else { $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; } next; } elsif (($arg eq "-o") or ($arg eq "--output")) { $outputdir_value = shift @ARGV; $valid = check_user_option ("output", $outputdir_value); if (not $valid) { $option_errors++; } next; } elsif (($arg eq "-O") or ($arg eq "--overwrite")) { $outputdir_value = shift @ARGV; $valid = check_user_option ("overwrite", $outputdir_value); if (not $valid) { $option_errors++; } next; } elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage")) { $hp_value = shift @ARGV; $valid = check_user_option ("highlight_percentage", $hp_value); if (not $valid) { $option_errors++; } next; } # Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) # Temporarily disabled { # Temporarily disabled $func_limit_value = shift @ARGV; # Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value); # Temporarily disabled # Temporarily disabled if (not $valid) # Temporarily disabled { # Temporarily disabled $option_errors++; # Temporarily disabled } # Temporarily disabled # Temporarily disabled next; # Temporarily disabled } # Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) # Temporarily disabled { # Temporarily disabled $calltree_value = shift @ARGV; # Temporarily disabled $valid = check_user_option ("calltree", $calltree_value); # Temporarily disabled # Temporarily disabled if (not $valid) # Temporarily disabled { # Temporarily disabled $option_errors++; # Temporarily disabled } # Temporarily disabled # Temporarily disabled next; # Temporarily disabled } # Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) # Temporarily disabled { # Temporarily disabled $tp_value = shift @ARGV; # Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value); # Temporarily disabled # Temporarily disabled if (not $valid) # Temporarily disabled { # Temporarily disabled $option_errors++; # Temporarily disabled } # Temporarily disabled # Temporarily disabled next; # Temporarily disabled } # Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) # Temporarily disabled { # Temporarily disabled $default_metrics_value = shift @ARGV; # Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value); # Temporarily disabled # Temporarily disabled if (not $valid) # Temporarily disabled { # Temporarily disabled $option_errors++; # Temporarily disabled } # Temporarily disabled # Temporarily disabled next; # Temporarily disabled } # Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) # Temporarily disabled { # Temporarily disabled $ignore_metrics_value = shift @ARGV; # Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value); # Temporarily disabled # Temporarily disabled if (not $valid) # Temporarily disabled { # Temporarily disabled $option_errors++; # Temporarily disabled } # Temporarily disabled # Temporarily disabled next; # Temporarily disabled } else { #------------------------------------------------------------------------------ # When we get to this part of the code it means that the current command line # argument is not a known option. # # We check if it is the name of an experiment directory and if so, add it to # the list with directories to use. # # If not, print an error message and increment the error variable because this # is clearly something that is not right. #------------------------------------------------------------------------------- if ($arg =~ /^\-.*/) { #------------------------------------------------------------------------------- # It is an option, but not a supported one. Print a message and increment # the error count. #------------------------------------------------------------------------------- $message = "option $arg is not a known option"; push (@g_user_input_errors, $message); $option_errors++; } else { #------------------------------------------------------------------------------- # Other than options, the input has to consist of at least one directory name. # First remove any trailing slashes (/) and then check if the name is valid. #------------------------------------------------------------------------------- $arg =~ s/\/*\/$//; if ($arg =~ /.+\.er$/) { #------------------------------------------------------------------------------- # It is the name of an experiment directory and is added to the list. #------------------------------------------------------------------------------- $found_exp_dir = $TRUE; push (@exp_dir_list, $arg); } else { #------------------------------------------------------------------------------- # It is not a valid experiment directory name. Print a message and exit. #------------------------------------------------------------------------------- $message = "not a valid experiment directory name: $arg"; push (@g_user_input_errors, $message); $option_errors++; } } } #-- End of last else } #-- End of while-loop #------------------------------------------------------------------------------- # Check if the name of the experiment directories is valid. Note that later # we check for these directories to exist. #------------------------------------------------------------------------------- if (not $found_exp_dir) { $message = "experiment directory name(s) are either not valid, or missing"; push (@g_user_input_errors, $message); $option_errors++; } #------------------------------------------------------------------------------ # Check for fatal errors to have occurred. If so, stop execution. Otherwise, # confirm the verbose setting. #------------------------------------------------------------------------------ if ($option_errors > 0) { gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found"); } else { gp_message ("debug", $subr_name, "no errors in the options found"); } return ($option_errors, $found_exp_dir, \@exp_dir_list); } #-- End of subroutine parse_and_check_user_options #------------------------------------------------------------------------------ # Parse the generated .dis files #------------------------------------------------------------------------------ sub parse_dis_files { my $subr_name = get_my_name (); my ($number_of_metrics_ref, $function_info_ref, $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 # in the address into generate_dis_html. #------------------------------------------------------------------------------ my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my $input_string = ${ $input_string_ref }; my %addressobj_index = %{ $addressobj_index_ref }; #------------------------------------------------------------------------------ # The regex section. #------------------------------------------------------------------------------ my $dis_filename_id_regex = 'file\.([0-9]+)\.dis'; my $filename; my $outputdir = append_forward_slash ($input_string); my @source_line = (); my $source_line_ref; my @metric = (); my $metric_ref; my $target_function; gp_message ("debug", $subr_name, "building disassembly files"); gp_message ("debug", $subr_name, "outputdir = $outputdir"); while (glob ($outputdir.'*.dis')) { gp_message ("debug", $subr_name, "processing disassembly file: $_"); my $base_name = get_basename ($_); if ($base_name =~ /$dis_filename_id_regex/) { if (defined ($1)) { gp_message ("debug", $subr_name, "processing disassembly file: $base_name $1"); if (exists ($function_info[$1]{"routine"})) { $target_function = $function_info[$1]{"routine"}; gp_message ("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function"); } if (exists ($g_function_tag_id{$target_function})) { gp_message ("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}"); } else { my $msg = "no function tag found for $target_function"; gp_message ("assertion", $subr_name, $msg); } } else { gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id"); } } $filename = $_; gp_message ("verbose", $subr_name, " Processing disassembly file $filename"); ($source_line_ref, $metric_ref) = generate_dis_html ( \$target_function, \$number_of_metrics, $function_info_ref, $function_address_and_index_ref, \$outputdir, \$filename, \@source_line, \@metric, \%addressobj_index); @source_line = @{ $source_line_ref }; @metric = @{ $metric_ref }; } return (0) } #-- End of subroutine parse_dis_files #------------------------------------------------------------------------------ # Parse the .src.txt files #------------------------------------------------------------------------------ sub parse_source_files { my $subr_name = get_my_name (); my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_; my $number_of_metrics = ${ $number_of_metrics_ref }; my $outputdir = ${ $outputdir_ref }; my $ignore_value; my $outputdir_with_slash = append_forward_slash ($outputdir); gp_message ("verbose", $subr_name, "building source files"); while (glob ($outputdir_with_slash.'*.src.txt')) { gp_message ("verbose", $subr_name, " Processing source file: $_"); gp_message ("debug", $subr_name, "processing source file: $_"); my $found_target = process_source ( $number_of_metrics, $function_info_ref, $outputdir_with_slash, $_); if (not $found_target) { gp_message ("debug", $subr_name, "target function not found"); } } } #-- End of subroutine parse_source_files #------------------------------------------------------------------------------ # Routine to prepend \\ to selected symbols. #------------------------------------------------------------------------------ sub prepend_backslashes { my $subr_name = get_my_name (); my ($target_string) = @_; gp_message ("debug", $subr_name, "target_string on entry = $target_string"); $target_string =~ s/\(/\\\(/g; $target_string =~ s/\)/\\\)/g; $target_string =~ s/\+/\\\+/g; $target_string =~ s/\[/\\\[/g; $target_string =~ s/\]/\\\]/g; $target_string =~ s/\*/\\\*/g; $target_string =~ s/\./\\\./g; $target_string =~ s/\$/\\\$/g; $target_string =~ s/\^/\\\^/g; $target_string =~ s/\#/\\\#/g; gp_message ("debug", $subr_name, "target_string on return = $target_string"); return ($target_string); } #-- End of subroutine prepend_backslashes #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub preprocess_function_files { my $subr_name = get_my_name (); my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_; my $outputdir = append_forward_slash ($input_string); my @sort_fields = @{ $sort_fields_ref }; my $error_code; my $cmd_output; my $re; # TBD $outputdir .= "/"; gp_message ("debug", $subr_name, "enter subroutine"); my %metric_description = %{ $metric_description_ref }; for my $m (keys %metric_description) { gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}"); } $re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC"); ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex"); if ($error_code != 0 ) { gp_message ("abort", $subr_name, "execution terminated"); } for my $field (@sort_fields) { $re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC"); ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex"); if ($error_code != 0 ) { gp_message ("abort", $subr_name, "execution terminated"); } } $re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC"); ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex"); if ($error_code != 0 ) { gp_message ("abort", $subr_name, "execution terminated"); } if ($g_user_settings{"calltree"}{"current_value"} eq "on") { $re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC"); ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex"); if ($error_code != 0 ) { gp_message ("abort", $subr_name, "execution terminated"); } } return (0); } #-- End of subroutine preprocess_function_files #------------------------------------------------------------------------------- # Print the help overview #------------------------------------------------------------------------------- sub print_help_info { print #-------Marker line - do not go beyond this line ------------------------------ "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n". "\n". "Process one or more experiments to generate a directory containing the\n" . "index.html file that may be used to browse the experiment data.\n". "\n". "Options:\n". "\n". " --help print usage information and exit.\n". " --version print the version number and exit.\n". " --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" . " messages about the processing of the data; default\n" . " is off.\n". #-------Marker line - do not go beyond this line ------------------------------ " -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" . " to assist with troubleshooting, or further\n" . " development of this tool; on gives a modest amount\n" . " of information; s, m, l, or xl gives an increasing\n" . " amount of information and off disables the printing\n" . " of debug information; note that currently on, s, m,\n" . " and l are equivalent; this is expected to change in\n" . " future updates; default is off.\n" . #-------Marker line - do not go beyond this line ------------------------------ " -hp, ----highlight-percentage <value> a percentage value in the interval\n" . " [0,100] to select and color code source\n" . " lines as well as instructions that are\n" . " within this percentage of the maximum\n" . " metric value(s); a value of zero (-hp 0)\n" . " disables this feature; the default is 90.\n". #-------Marker line - do not go beyond this line ------------------------------ " -o, --output <dir-name> use <dir-name> to store the results in; the\n" . " default name is ./display.<n>.html with <n> the\n" . " first positive integer number not in use; an\n" . " existing directory is not overwritten.\n". #-------Marker line - do not go beyond this line ------------------------------ " -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" . " overwrite any existing directory with the\n" . " same name; make sure that umask is set to the\n" . " correct access permissions.\n" . #-------Marker line - do not go beyond this line ------------------------------ " -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" . " verbose messages; if set to on, the settings for\n" . " verbose, warnings and debug are ignored; default\n" . " is off.\n". #-------Marker line - do not go beyond this line ------------------------------ " -w, --warnings {on|off} enable/disable run time warning messages;\n" . " default is on.\n". "\n". # Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n". # Temmporarily disabled " this is an integer number; set to 0 to process all\n". # Temmporarily disabled " functions; the default value is 100.\n". # Temmporarily disabled "\n". # Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n". # Temmporarily disabled " from the bottom of the first page; default is off.\n". # Temmporarily disabled "\n". # Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n". # Temmporarily disabled " inclusion of functions for each metric will take\n". # Temmporarily disabled " place in sort order until the percentage has been\n". # Temmporarily disabled " reached.\n". # Temmporarily disabled "\n". # Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n". # Temmporarily disabled " and use a default set of metrics; the default is off.\n". # Temmporarily disabled "\n". # Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n". # Temmporarily disabled "\n". # Temmporarily disabled "Environment:\n". # Temmporarily disabled "\n". # Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n". # Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n". # Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n". # Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n". # Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n". # Temmporarily disabled "\n". "Documentation:\n". "\n". "A getting started guide for gprofng is maintained as a Texinfo manual.\n" . "If the info and gprofng programs are properly installed at your site,\n" . "the command \"info gprofng\" should give you access to this document.\n". "\n". "See also:\n". "\n". "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " . "gp-display-text(1)\n"; return (0); } #-- End of subroutine print_help_info #------------------------------------------------------------------------------- # Print the meta data for each experiment directory. #------------------------------------------------------------------------------- sub print_meta_data_experiments { my $subr_name = get_my_name (); my ($mode) = @_; for my $exp (sort keys %g_exp_dir_meta_data) { for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}}) { gp_message ($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}"); } } return (0); } #-- End of subroutine print_meta_data_experiments #------------------------------------------------------------------------------ # Brute force subroutine that prints the contents of a structure with function # level information. This version is for a top level array structure, # followed by a hash. #------------------------------------------------------------------------------ sub print_metric_function_array { my $subr_name = get_my_name (); my ($metric, $struct_type_name, $target_structure_ref) = @_; my @target_structure = @{$target_structure_ref}; gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); for my $fields (sort keys @target_structure) { for my $elems (sort keys % {$target_structure[$fields]}) { my $msg = $struct_type_name."{$metric}[$fields]{$elems} = "; $msg .= $target_structure[$fields]{$elems}; gp_message ("debugXL", $subr_name, $msg); } } return (0); } #-- End of subroutine print_metric_function_array #------------------------------------------------------------------------------ # Brute force subroutine that prints the contents of a structure with function # level information. This version is for a top level hash structure. The # next level may be another hash, or an array. #------------------------------------------------------------------------------ sub print_metric_function_hash { my $subr_name = get_my_name (); my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_; my %target_structure = %{$target_structure_ref}; gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); for my $fields (sort keys %target_structure) { gp_message ("debugXL", $subr_name, "metric = $metric fields = $fields"); if ($sub_struct_type eq "hash_hash") { for my $elems (sort keys %{$target_structure{$fields}}) { my $txt = $struct_type_name."{$metric}{$fields}{$elems} = "; $txt .= $target_structure{$fields}{$elems}; gp_message ("debugXL", $subr_name, $txt); } } elsif ($sub_struct_type eq "hash_array") { my $values = ""; for my $elems (sort keys @{$target_structure{$fields}}) { $values .= "$target_structure{$fields}[$elems] "; } gp_message ("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values"); } else { my $msg = "sub-structure type '$sub_struct_type' is not supported"; gp_message ("assertion", $subr_name, $msg); } } return (0); } #-- End of subroutine print_metric_function_hash #------------------------------------------------------------------------------ # Print the opening message. #------------------------------------------------------------------------------ sub print_opening_message { my $subr_name = get_my_name (); #------------------------------------------------------------------------------ # Since the second argument is an array, we pass it in by reference. The # alternative is to make it the last argument. #------------------------------------------------------------------------------ my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_; my @exp_dir_list = @{$exp_dir_list_ref}; my $msg; my $no_of_dirs = scalar (@exp_dir_list); #------------------------------------------------------------------------------ # Build a comma separated list with all directory names. If there is only one # entry, the leading comma will not be inserted. #------------------------------------------------------------------------------ my $dir_list = join (", ", @exp_dir_list); #------------------------------------------------------------------------------ # If there are at least two entries, find the last comma and replace it by # " and". Note that we know there is at least one comma, so the value # returned by rindex () cannot be -1. #------------------------------------------------------------------------------ if ($no_of_dirs > 1) { my $last_comma = rindex ($dir_list, ","); my $ignore_value = substr ($dir_list, $last_comma, 1, " and"); } $msg = "start $tool_name, generating directory $outputdir from $dir_list"; gp_message ("verbose", $subr_name, $msg); if ($time_percentage_multiplier < 1.0) { $msg = "Handle at least "; } else { $msg = "Handle "; } $msg .= ($time_percentage_multiplier*100.0)."% of the time"; gp_message ("verbose", $subr_name, $msg); } #-- End of subroutine print_opening_message #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ sub print_program_header { my $subr_name = get_my_name (); my ($mode, $tool_name, $binutils_version) = @_; my $header_limit = 60; my $dashes = "-"; #------------------------------------------------------------------------------ # Generate the dashed line #------------------------------------------------------------------------------ for (2 .. $header_limit) { $dashes .= "-"; } gp_message ($mode, $subr_name, $dashes); gp_message ($mode, $subr_name, "Tool name: $tool_name"); gp_message ($mode, $subr_name, "Version : $binutils_version"); gp_message ($mode, $subr_name, "Date : " . localtime ()); gp_message ($mode, $subr_name, $dashes); } #-- End of subroutine print_program_header #------------------------------------------------------------------------------ # Print a comment string, followed by the values of the options. The list # with the keywords is sorted alphabetically. # # The value stored in $mode is passed on to gp_message (). The intended use # for this is to call this function in verbose and/or debug mode. # # The comment string is converted to uppercase. # # In case the length of the comment exceeds the length of the dashed line, # the comment line is allowed to stick out to the right. # # If the length of the comment is less than the dashed line, it is centered # relative to the # length of the dashed line. # If the length of the comment and this line do not divide, an extra space is # added to the left of the comment. # # For example, if the comment is 55 long, there are 5 spaces to be distributed. # There will be 3 spaces, followed by the comment. #------------------------------------------------------------------------------ sub print_table_user_settings { my $subr_name = get_my_name (); my ($mode, $comment) = @_; my $leftover; my $padding; my $keyword; my $user_option; my $defined; my $value; my $data_type; my $HEADER_LIMIT = 60; my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value"); #------------------------------------------------------------------------------ # Generate the dashed line #------------------------------------------------------------------------------ my $dashes = "-"; for (2 .. $HEADER_LIMIT) { $dashes .= "-"; } #------------------------------------------------------------------------------ # Determine the padding needed to the left of the comment. #------------------------------------------------------------------------------ my $length_comment = length ($comment); $leftover = $length_comment%2; if ($length_comment <= ($HEADER_LIMIT-2)) { $padding = ($HEADER_LIMIT - $length_comment + $leftover)/2; } else { $padding = 0; } #------------------------------------------------------------------------------ # Generate the first blank part of the line. #------------------------------------------------------------------------------ my $blank_line = ""; for (1 .. $padding) { $blank_line .= " "; } #------------------------------------------------------------------------------ # Add the comment line with the first letter in uppercase. #------------------------------------------------------------------------------ my $final_comment = $blank_line.ucfirst ($comment); gp_message ($mode, $subr_name, $dashes); gp_message ($mode, $subr_name, $final_comment); gp_message ($mode, $subr_name, $dashes); gp_message ($mode, $subr_name, $header); gp_message ($mode, $subr_name, $dashes); #------------------------------------------------------------------------------ # Print a line for each option. The list is sorted alphabetically. #------------------------------------------------------------------------------ for my $rc_keyword (sort keys %g_user_settings) { $keyword = $rc_keyword; $user_option = $g_user_settings{$rc_keyword}{"option"}; $defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set"); $data_type = $g_user_settings{$rc_keyword}{"data_type"}; if (defined ($g_user_settings{$rc_keyword}{"current_value"})) { $value = $g_user_settings{$rc_keyword}{"current_value"}; if ($data_type eq "boolean") { $value = $value ? "on" : "off"; } } else { $value = "undefined"; } my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value); gp_message ($mode, $subr_name, $print_line); } } #-- End of subroutine print_table_user_settings #------------------------------------------------------------------------------ # Dump the contents of nested hash "g_user_settings". Some simple formatting # is applied to make it easier to distinguish the various values. #------------------------------------------------------------------------------ sub print_user_settings { my $subr_name = get_my_name (); my ($mode, $comment) = @_; my $keyword_value_pair; gp_message ($mode, $subr_name, $comment); for my $rc_keyword (keys %g_user_settings) { my $print_line = sprintf ("%-20s =>", $rc_keyword); for my $fields (sort keys %{ $g_user_settings{$rc_keyword} }) { if (defined ($g_user_settings{$rc_keyword}{$fields})) { $keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields}; } else { $keyword_value_pair = $fields." = ". "undefined"; } $print_line = join (" ", $print_line, $keyword_value_pair); } gp_message ($mode, $subr_name, $print_line); } } #-- End of subroutine print_user_settings #------------------------------------------------------------------------------ # Print the version number and license information. #------------------------------------------------------------------------------ sub print_version_info { print "$version_info\n"; print "Copyright (C) 2023 Free Software Foundation, Inc.\n"; print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n"; print "This is free software: you are free to change and redistribute it.\n"; print "There is NO WARRANTY, to the extent permitted by law.\n"; return (0); } #-- End of subroutine print_version_info #------------------------------------------------------------------------------ # Process the call tree input data and generate HTML output. #------------------------------------------------------------------------------ sub process_calltree { my $subr_name = get_my_name (); my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, $input_string) = @_; my @function_info = @{ $function_info_ref }; my %function_address_info = %{ $function_address_info_ref }; my %addressobjtextm = %{ $addressobjtextm_ref }; my $outputdir = append_forward_slash ($input_string); my @call_tree_data = (); my $LANG = $g_locale_settings{"LANG"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $infile = $outputdir . "calltree"; my $outfile = $outputdir . "calltree.html"; open (CALL_TREE_IN, "<", $infile) or die ("Not able to open calltree file $infile for reading - '$!'"); gp_message ("debug", $subr_name, "opened file $infile for reading"); open (CALL_TREE_OUT, ">", $outfile) or die ("Not able to open $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); gp_message ("debug", $subr_name, "building calltree file $outfile"); #------------------------------------------------------------------------------ # The directory name is potentially used below, but since it is a constant, # we get it here and only once. #------------------------------------------------------------------------------ # my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,""); # gp_message ("debug", $subr_name, "directory_name = $directory_name"); #------------------------------------------------------------------------------ # Generate some of the structures used in the HTML output. #------------------------------------------------------------------------------ my $file_title = "Call Tree overview"; my $html_header = ${ create_html_header (\$file_title) }; my $html_home_right = ${ generate_home_link ("right") }; my $page_title = "Call Tree View"; my $size_text = "h2"; my $position_text = "center"; my $html_title_header = ${ generate_a_header ( \$page_title, \$size_text, \$position_text) }; #------------------------------------------------------------------------------- # Get the acknowledgement, return to main link, and final html statements. #------------------------------------------------------------------------------- my $html_home_left = ${ generate_home_link ("left") }; my $html_acknowledgement = ${ create_html_credits () }; my $html_end = ${ terminate_html_document () }; #------------------------------------------------------------------------------ # Read all of the file into array with the name call_tree_data. #------------------------------------------------------------------------------ chomp (@call_tree_data = <CALL_TREE_IN>); close (CALL_TREE_IN); #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Process the data here and generate the HTML lines. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Print the top part of the HTML file. #------------------------------------------------------------------------------ print CALL_TREE_OUT $html_header; print CALL_TREE_OUT $html_home_right; print CALL_TREE_OUT $html_title_header; #------------------------------------------------------------------------------- # Print the generated HTML structures here. #------------------------------------------------------------------------------- ## print CALL_TREE_OUT "$_" for @whatever; ## print CALL_TREE_OUT "<pre>\n"; ## print CALL_TREE_OUT "$_\n" for @whatever2; ## print CALL_TREE_OUT "</pre>\n"; #------------------------------------------------------------------------------- # Print the last part of the HTML file. #------------------------------------------------------------------------------- print CALL_TREE_OUT $html_home_left; print CALL_TREE_OUT "<br>\n"; print CALL_TREE_OUT $html_acknowledgement; print CALL_TREE_OUT $html_end; close (CALL_TREE_OUT); return (0); } #-- End of subroutine process_calltree #------------------------------------------------------------------------------- # Process the generated experiment info file(s). #------------------------------------------------------------------------------- sub process_experiment_info { my $subr_name = get_my_name (); my ($experiment_data_ref) = @_; my @exp_info; my @experiment_data = @{ $experiment_data_ref }; my $exp_id; my $exp_name; my $exp_data_file; my $input_line; my $target_cmd; my $hostname ; my $OS; my $page_size; my $architecture; my $start_date; my $end_experiment; my $data_collection_duration; my $total_thread_time; my $user_cpu_time; my $user_cpu_percentage; my $system_cpu_time; my $system_cpu_percentage; my $sleep_time; my $sleep_percentage; #------------------------------------------------------------------------------- # Define the regular expressions used to capture the info. #------------------------------------------------------------------------------- # Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2' my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\''; # Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64' my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\''; # Experiment started Mon Aug 30 13:03:20 2021 my $start_date_regex = '\s*Experiment started\s+(.+)'; # Experiment Ended: 1.812441219 my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)'; # Data Collection Duration: 1.812441219 my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)'; # Total Thread Time (sec.): 1.812 my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)'; # User CPU: 1.685 ( 95.0%) my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)'; # System CPU: 0.088 ( 5.0%) my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)'; # Sleep: 0. ( 0. %) my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)'; #------------------------------------------------------------------------------- # Scan the experiment data and select the info of interest. #------------------------------------------------------------------------------- for my $i (sort keys @experiment_data) { $exp_id = $experiment_data[$i]{"exp_id"}; $exp_name = $experiment_data[$i]{"exp_name_full"}; $exp_data_file = $experiment_data[$i]{"exp_data_file"}; my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file"; gp_message ("debug", $subr_name, $msg); open (EXPERIMENT_INFO, "<", $exp_data_file) or die ("$subr_name - unable to open file $exp_data_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $exp_data_file for reading"); chomp (@exp_info = <EXPERIMENT_INFO>); #------------------------------------------------------------------------------- # Process the info for the current experiment. #------------------------------------------------------------------------------- for my $line (0 .. $#exp_info) { $input_line = $exp_info[$line]; my $msg = "exp_id = $exp_id: input_line = $input_line"; gp_message ("debugM", $subr_name, $msg); if ($input_line =~ /$target_cmd_regex/) { $target_cmd = $2; gp_message ("debugM", $subr_name, "$exp_id => $target_cmd"); $experiment_data[$i]{"target_cmd"} = $target_cmd; } elsif ($input_line =~ /$host_system_regex/) { $hostname = $1; $OS = $2; $page_size = $3; $architecture = $4; gp_message ("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture"); $experiment_data[$i]{"hostname"} = $hostname; $experiment_data[$i]{"OS"} = $OS; $experiment_data[$i]{"page_size"} = $page_size; $experiment_data[$i]{"architecture"} = $architecture; } elsif ($input_line =~ /$start_date_regex/) { $start_date = $1; gp_message ("debugM", $subr_name, "$exp_id => $start_date"); $experiment_data[$i]{"start_date"} = $start_date; } elsif ($input_line =~ /$end_experiment_regex/) { $end_experiment = $1; gp_message ("debugM", $subr_name, "$exp_id => $end_experiment"); $experiment_data[$i]{"end_experiment"} = $end_experiment; } elsif ($input_line =~ /$data_collection_duration_regex/) { $data_collection_duration = $1; gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration"); $experiment_data[$i]{"data_collection_duration"} = $data_collection_duration; } #------------------------------------------------------------------------------ # Start Label: Total # End Label: Total # Start Time (sec.): 0.000 # End Time (sec.): 1.812 # Duration (sec.): 1.812 # Total Thread Time (sec.): 1.812 # Average number of Threads: 1.000 # # Process Times (sec.): # User CPU: 1.666 ( 91.9%) # System CPU: 0.090 ( 5.0%) # Trap CPU: 0. ( 0. %) # User Lock: 0. ( 0. %) # Data Page Fault: 0. ( 0. %) # Text Page Fault: 0. ( 0. %) # Kernel Page Fault: 0. ( 0. %) # Stopped: 0. ( 0. %) # Wait CPU: 0. ( 0. %) # Sleep: 0.056 ( 3.1%) #------------------------------------------------------------------------------ elsif ($input_line =~ /$total_thread_time_regex/) { $total_thread_time = $1; gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time"); $experiment_data[$i]{"total_thread_time"} = $total_thread_time; } elsif ($input_line =~ /$user_cpu_regex/) { $user_cpu_time = $1; $user_cpu_percentage = $2; gp_message ("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage"); $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")"; $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage; } elsif ($input_line =~ /$system_cpu_regex/) { $system_cpu_time = $1; $system_cpu_percentage = $2; gp_message ("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage"); $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")"; $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage; } elsif ($input_line =~ /$sleep_regex/) { $sleep_time = $1; $sleep_percentage = $2; $experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")"; $experiment_data[$i]{"sleep_percentage"} = $sleep_percentage; my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " . "sleep_percentage = $sleep_percentage"; gp_message ("debugM", $subr_name, $msg); } } } for my $keys (0 .. $#experiment_data) { for my $fields (sort keys %{ $experiment_data[$keys] }) { my $msg = "experiment_data[$keys]{$fields} = " . $experiment_data[$keys]{$fields}; gp_message ("debugM", $subr_name, $msg); } } return (\@experiment_data); } #-- End of subroutine process_experiment_info #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub process_function_files { my $subr_name = get_my_name (); my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier, $summary_metrics, $process_all_functions, $elf_loadobjects_found, $outputdir, $sort_fields_ref, $function_info_ref, $function_address_and_index_ref, $LINUX_vDSO_ref, $metric_description_ref, $elf_arch, $base_va_executable, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; my $old_fsummary; my $total_attributed_time; my $current_attributed_time; my $value; my @exp_dir_list = @{ $exp_dir_list_ref }; my @function_info = @{ $function_info_ref }; my %function_address_and_index = %{ $function_address_and_index_ref }; my @sort_fields = @{ $sort_fields_ref }; my %metric_description = %{ $metric_description_ref }; my %elf_rats = %{ $elf_rats_ref }; #------------------------------------------------------------------------------ # The regex section. # # TBD: Remove the part regarding clones. Legacy. #------------------------------------------------------------------------------ my $replace_quote_regex = '"/\"'; my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])'; my %addressobj_index = (); my %function_address_info = (); my $function_address_info_ref; $outputdir = append_forward_slash ($outputdir); my %functions_per_metric_indexes = (); my $functions_per_metric_indexes_ref; my %functions_per_metric_first_index = (); my $functions_per_metric_first_index_ref; my %routine_list = (); my %handled_routines = (); #------------------------------------------------------------------------------ # TBD: Name cleanup needed. #------------------------------------------------------------------------------ my $number_of_metrics; my $expr_name; my $routine; my $tmp; my $loadobj; my $PCA; my $address_field; my $limit_txt; my $n_metrics_text; my $disfile; my $srcfile; my $RIN; my $gp_listings_cmd; my $gp_display_text_cmd; my $ignore_value; my $result_file = $outputdir . "gp-listings.out"; my $gp_error_file = $outputdir . "gp-listings.err"; my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $length_of_string = length ($outputdir); $expr_name = join (" ", @exp_dir_list); gp_message ("debug", $subr_name, "expr_name = $expr_name"); #------------------------------------------------------------------------------ # Loop over the files in $outputdir. #------------------------------------------------------------------------------ while (glob ($outputdir.'*.sort.func-PC')) { my $metric; my $infile; my $ignore_value; my $suffix_not_used; $infile = $_; ($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC"); gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-"); # Function_info creates the functions files from the PC ones # as well as culling PC and metric information ($function_address_info_ref, $functions_per_metric_first_index_ref, $functions_per_metric_indexes_ref) = function_info ( $outputdir, $infile, $metric, $LINUX_vDSO_ref); @{$function_address_info{$metric}} = @{$function_address_info_ref}; %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref}; %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref}; $ignore_value = print_metric_function_array ($metric, "function_address_info", \@{$function_address_info{$metric}}); $ignore_value = print_metric_function_hash ("hash_hash", $metric, "functions_per_metric_first_index", \%{$functions_per_metric_first_index{$metric}}); $ignore_value = print_metric_function_hash ("hash_array", $metric, "functions_per_metric_indexes", \%{$functions_per_metric_indexes{$metric}}); } #------------------------------------------------------------------------------ # Get header info for use in post processing er_html output #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "get_hdr_info section"); get_hdr_info ($outputdir, $outputdir."functions.sort.func"); for my $field (@sort_fields) { get_hdr_info ($outputdir, $outputdir."$field.sort.func"); } #------------------------------------------------------------------------------ # Caller-callee #------------------------------------------------------------------------------ get_hdr_info ($outputdir, $outputdir."calls.sort.func"); #------------------------------------------------------------------------------ # Calltree #------------------------------------------------------------------------------ if ($g_user_settings{"calltree"}{"current_value"} eq "on") { get_hdr_info ($outputdir, $outputdir."calltree.sort.func"); } gp_message ("debug", $subr_name, "process functions"); my $scriptfile = $outputdir.'gp-script'; my $script_metrics = "$summary_metrics"; my $func_limit = $g_user_settings{"func_limit"}{"current_value"}; open (SCRIPT, ">", $scriptfile) or die ("Unable to create script file $scriptfile - '$!'"); gp_message ("debug", $subr_name, "opened script file $scriptfile for writing"); print SCRIPT "# limit $func_limit\n"; print SCRIPT "limit $func_limit\n"; print SCRIPT "# thread_select all\n"; print SCRIPT "thread_select all\n"; print SCRIPT "# metrics $script_metrics\n"; print SCRIPT "metrics $script_metrics\n"; for my $metric (@sort_fields) { gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}"); $total_attributed_time = 0; $current_attributed_time = 0; $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total> if ($convert_to_dot) { $value =~ s/$decimal_separator/\./; } $total_attributed_time = $value; #------------------------------------------------------------------------------ # start at 1 - skipping <Total> #------------------------------------------------------------------------------ for my $INDEX (1 .. $#{$function_address_info{$metric}}) { #------------------------------------------------------------------------------ #Looking to handle at least 99% of the time - or what the user asked for #------------------------------------------------------------------------------ $value = $function_address_info{$metric}[$INDEX]{"metric_value"}; $routine = $function_address_info{$metric}[$INDEX]{"routine"}; gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time"); gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)"); if ($convert_to_dot) { $value =~ s/$decimal_separator/\./; } if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or ( ($total_attributed_time == 0) and ($value>0) ) or $process_all_functions) { $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"}; if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA})) { gp_message ("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}"); } if (not exists ($function_address_and_index{$routine}{$PCA})) { gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}"); } if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and exists ($function_address_and_index{$routine}{$PCA})) { #------------------------------------------------------------------------------ # handled_routines now contains $RI from "first_metric" (?) #------------------------------------------------------------------------------ $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; if ($metric_description{$metric} =~ /Exclusive Total CPU Time/) { $routine_list{$routine} = 1 } gp_message ("debugXL", $subr_name, " $routine is candidate"); } else { die ("internal error for metric $metric and routine $routine"); } $current_attributed_time += $value; } } } #------------------------------------------------------------------------------ # Sort numerically in ascending order. #------------------------------------------------------------------------------ for my $routine_index (sort {$a <=> $b} keys %handled_routines) { $routine = $function_info[$routine_index]{"routine"}; gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine"); next unless $routine_list{$routine}; # not used $source = $function_info[$routine_index]{"Source File"}; $function_info[$routine_index]{"srcline"} = ""; $address_field = $function_info[$routine_index]{"addressobjtext"}; ## $disfile = "file\.$routine_index\.dis"; $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"}; $srcfile = ""; $srcfile = "file\.$routine_index\.src.txt"; #------------------------------------------------------------------------------ # If the file is unknown, we can disassemble anyway and add disassembly # to the script. #------------------------------------------------------------------------------ print SCRIPT "# outfile $outputdir"."$disfile\n"; print SCRIPT "outfile $outputdir"."$disfile\n"; #------------------------------------------------------------------------------ # TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope. #------------------------------------------------------------------------------ $tmp = $routine; $tmp =~ s/$replace_quote_regex//g; print SCRIPT "# disasm \"$tmp\" $address_field\n"; print SCRIPT "disasm \"$tmp\" $address_field\n"; if ($srcfile=~/file/) { print SCRIPT "# outfile $outputdir"."$srcfile\n"; print SCRIPT "outfile $outputdir"."$srcfile\n"; print SCRIPT "# source \"$tmp\" $address_field\n"; print SCRIPT "source \"$tmp\" $address_field\n"; } if ($routine =~ /$find_clone_regex/) { my ($clone_routine) = $1.$2.$3.$4; my ($clone) = $3; } } close SCRIPT; #------------------------------------------------------------------------------ # Remember the number of handled routines depends on the limit setting passed # to er_print together with the sorting order on the metrics, which usually results # in different routines at the top. Thus $RIN below can be greater than the limit. #------------------------------------------------------------------------------ $RIN = scalar (keys %handled_routines); if (!$func_limit) { $limit_txt = "unlimited"; } else { $limit_txt = $func_limit - 1; } $number_of_metrics = scalar (@sort_fields); $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics"; gp_message ("debugXL", $subr_name, "built function list with $RIN functions"); gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt"); # add ELF program header offset for my $routine_index (sort {$a <=> $b} keys %handled_routines) { $routine = $function_info[$routine_index]{"routine"}; $loadobj = $function_info[$routine_index]{"Load Object"}; gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch"); if ($loadobj ne '') { # <Truncated-stack> is associated with <Total>. Its load object is <Total> if ($loadobj eq "<Total>") { next; } # Have seen a routine called <Unknown>. Its load object is <Unknown> if ($loadobj eq "<Unknown>") { next; } ############################################################################### ## RUUD: The new approach gives a different result. Investigate this. # # Turns out the new code improves the result. The addresses are now correct # and as a result, more ftag's are created later on. ############################################################################### gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); $function_info[$routine_index]{"addressobj"} += bigint::hex ( determine_base_va_address ( $executable_name, $base_va_executable, $loadobj, $routine)); $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index; gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}"); } } #------------------------------------------------------------------------------ # Get the disassembly and source code output. #------------------------------------------------------------------------------ $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " . "-compare off -script $scriptfile $expr_name"; $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file"; gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd"); gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output"); my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $gp_error_file); gp_message ("abort", "execution terminated"); } return (\@function_info, \%function_address_info, \%addressobj_index); } #-- End of subroutine process_function_files #------------------------------------------------------------------------------ # Process the information found in the function overview file passed in. # # Example input: # # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Functions sorted by metric: Exclusive Total CPU Time # # PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl. # Total Cycles Instructions Last-Level IPC CPI # CPU sec. sec. Executed Cache Misses # 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634 # 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651 # 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000 #------------------------------------------------------------------------------ sub process_function_overview { my $subr_name = get_my_name (); my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_; my $metric = ${ $metric_ref }; my $exp_type = ${ $exp_type_ref }; my $summary_metrics = ${ $summary_metrics_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my %function_view_structure = %{ $function_view_structure_ref }; my $overview_file = ${ $overview_file_ref }; my $all_metrics; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $length_of_block; my $elements_in_name; my $full_hex_address; my $header_line; my $hex_address; my $html_line; my $input_line; my $name_regex; my $no_of_fields; my $metrics_length; my $missing_digits; my $remaining_part_header; my $routine; my $routine_length; my $scan_header = $FALSE; my $scan_function_data = $FALSE; my $string_length; my $total_header_lines; my @address_field = (); my @fields = (); my @function_data = (); my @function_names = (); my @function_view_array = (); my @function_view_modified = (); my @header_lines = (); my @metrics_part = (); my @metric_values = (); #------------------------------------------------------------------------------ # The regex section. #------------------------------------------------------------------------------ my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)'; my $empty_line_regex = '^\s*$'; my $catch_all_regex = '\s*(.*)'; my $get_hex_address_regex = '(\d+):0x(\S+)'; my $get_addr_offset_regex = '^@\d+:'; my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)'; my $backward_slash_regex = '\/'; #------------------------------------------------------------------------------ if (is_file_empty ($overview_file)) { gp_message ("error", $subr_name, "assertion error: file $overview_file is empty"); } open (FUNC_OVERVIEW, "<", $overview_file) or die ("$subr_name - unable to open file $overview_file for reading '$!'"); gp_message ("debug", $subr_name, "opened file $overview_file for reading"); gp_message ("debug", $subr_name, "processing file for exp_type = $exp_type"); gp_message ("debugM", $subr_name, "header_name_regex = $header_name_regex"); gp_message ("debugM", $subr_name, "total_marker_regex = $total_marker_regex"); gp_message ("debugM", $subr_name, "empty_line_regex = $empty_line_regex"); gp_message ("debugM", $subr_name, "catch_all_regex = $catch_all_regex"); gp_message ("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex"); gp_message ("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex"); gp_message ("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex"); gp_message ("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex"); #------------------------------------------------------------------------------ # Read the input file into memory. #------------------------------------------------------------------------------ chomp (@function_data = <FUNC_OVERVIEW>); gp_message ("debug", $subr_name, "read all of file $overview_file into memory"); #------------------------------------------------------------------------------- # Parse the function view info and store the data. #------------------------------------------------------------------------------- my $max_header_length = 0; my $max_metrics_length = 0; #------------------------------------------------------------------------------ # Loop over all the lines. Extract the header, metric values, function names, # and the addresses. # # This is also where the maximum lengths for the header and metric lines are # computed. This is used to get the correct alignment in the HTML output. #------------------------------------------------------------------------------ for (my $line = 0; $line <= $#function_data; $line++) { $input_line = $function_data[$line]; gp_message ("debugXL", $subr_name, "input_line = $input_line"); #------------------------------------------------------------------------------ # The table header is assumed to start at the line that has "Name" in it. # The header ends when we see the function name "<Total>". #------------------------------------------------------------------------------ if ($input_line =~ /$header_name_regex/) { $scan_header = $TRUE; } elsif ($input_line =~ /$total_marker_regex/) { $scan_header = $FALSE; $scan_function_data = $TRUE; } if ($scan_header) { #------------------------------------------------------------------------------ # This group is only defined for the first line of the header and $4 contains # the remaining part of the line after "Name", without the leading spaces. #------------------------------------------------------------------------------ if (defined ($4)) { $remaining_part_header = $4; my $msg = "remaining_part_header = $remaining_part_header"; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Determine the maximum length of the header. This needs to be done before # the HTML controls are added. #------------------------------------------------------------------------------ my $header_length = length ($remaining_part_header); $max_header_length = max ($max_header_length, $header_length); #------------------------------------------------------------------------------ # TBD Should change this and not yet include html in header_lines #------------------------------------------------------------------------------ $html_line = "<b>" . $remaining_part_header . "</b>"; push (@header_lines, $html_line); gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); gp_message ("debugXL", $subr_name, "html_line = $html_line"); } #------------------------------------------------------------------------------ # Captures the subsequent header lines. Assume they exist. #------------------------------------------------------------------------------ elsif ($input_line =~ /$catch_all_regex/) { $header_line = $1; gp_message ("debugXL", $subr_name, "header_line = $header_line"); my $header_length = length ($header_line); $max_header_length = max ($max_header_length, $header_length); #------------------------------------------------------------------------------ # TBD Should change this and not yet include html in header_lines #------------------------------------------------------------------------------ $html_line = "<b>" . $header_line . "</b>"; push (@header_lines, $html_line); gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); gp_message ("debugXL", $subr_name, "html_line = $html_line"); } } #------------------------------------------------------------------------------ # This is a line with function data. #------------------------------------------------------------------------------ if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/))) { @fields = split (" ", $input_line); $no_of_fields = $#fields + 1; $elements_in_name = $no_of_fields - $number_of_metrics - 1; gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name"); #------------------------------------------------------------------------------ # TBD: Handle this better in case a function entry has more than 2 words. # Build the regex dynamically and use eval to capture the correct group. # CHECK CODE IN GENERATE_CALLER_CALLEE #------------------------------------------------------------------------------ if ($elements_in_name == 1) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)'; } elsif ($elements_in_name == 2) { $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)'; } else { gp_message ("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit"); } if ($input_line =~ /$name_regex/) { $full_hex_address = $1; $routine = $2; if ($elements_in_name == 1) { $all_metrics = $3; } elsif ($elements_in_name == 2) { $all_metrics = $5; } #------------------------------------------------------------------------------ # In case the last metric is 0. only, we append 3 extra characters that # represent zero. We cannot change the number to 0.000 though because that # has a different interpretation than 0. # In a later phase, the "ZZZ" symbol will be removed again, but for now it # creates consistency in, for example, the length of the metrics part. #------------------------------------------------------------------------------ if ($all_metrics =~ /$zero_dot_at_end_regex/) { if (defined ($1) ) { #------------------------------------------------------------------------------ # Somewhat overkill, but remove the leading "\" from the decimal separator # in the debug print since it is used for internal purposes only. #------------------------------------------------------------------------------ my $decimal_point = $decimal_separator; $decimal_point =~ s/$backward_slash_regex//; my $txt = "all_metrics = $all_metrics ended with 0"; $txt .= "$decimal_point ($decimal_separator)"; gp_message ("debugXL", $subr_name, $txt); $all_metrics .= "ZZZ"; } } $metrics_length = length ($all_metrics); $max_metrics_length = max ($max_metrics_length, $metrics_length); gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); if ($full_hex_address =~ /$get_hex_address_regex/) { $hex_address = "0x" . $2; } push (@address_field, $hex_address); push (@metric_values, $all_metrics); #------------------------------------------------------------------------------ # Record the function name "as is". Below we figure out what the final name # should be in case there are multiple occurrences of the same name. # # The reason to decouple this is to avoid the code gets too complex here. #------------------------------------------------------------------------------ push (@function_names, $routine); } } } #-- End of loop over the input lines #------------------------------------------------------------------------------ # Store the maximum lengths for the header and metrics. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length"); gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length"); $function_view_structure{"max header length"} = $max_header_length; $function_view_structure{"max metrics length"} = $max_metrics_length; #------------------------------------------------------------------------------ # Determine the final name for the functions and set up the HTML block. #------------------------------------------------------------------------------ my @final_html_function_block = (); my @function_index_list = (); #------------------------------------------------------------------------------ # First, an index list is built. If we are to index the functions in order of # appearance in the function overview from 0 to n-1, the value of the array # for index "i" is the index into the large "function_info" structure. This # has the final name, the html function block, etc. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ ## TBD: Use get_index_function_info??!! #------------------------------------------------------------------------------ for my $i (keys @function_names) { #------------------------------------------------------------------------------ # Get the function name and the address from the function overview. The # address is used to differentiate in case a function has multiple occurences. #------------------------------------------------------------------------------ my $routine = $function_names[$i]; my $current_address = $address_field[$i]; my $found_a_match = $FALSE; my $final_function_name; my $ref_index; #------------------------------------------------------------------------------ # Check if there are duplicate entries for this function. If there are, use # the address to find the right match in the function_info structure. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences"); if (exists ($g_multi_count_function{$routine})) { gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); for my $ref (keys @{ $g_map_function_to_index{$routine} }) { my $ref_index = $g_map_function_to_index{$routine}[$ref]; my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; #------------------------------------------------------------------------------ # The address has the following format: 6:0x0003af50, but we only need the # part after the colon and remove the first part. #------------------------------------------------------------------------------ $addr_offset =~ s/$get_addr_offset_regex//; gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index"); gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); if ($addr_offset eq $current_address) #------------------------------------------------------------------------------ # There is a match and we can store the index. #------------------------------------------------------------------------------ { $found_a_match = $TRUE; push (@function_index_list, $ref_index); last; } } } else { #------------------------------------------------------------------------------ # This is the easy case. There is only one index value. We do check if the # array element that contains it, exists. If this is not the case, something # has gone horribly wrong earlier and we need to bail out. #------------------------------------------------------------------------------ if (defined ($g_map_function_to_index{$routine}[0])) { $found_a_match = $TRUE; $ref_index = $g_map_function_to_index{$routine}[0]; push (@function_index_list, $ref_index); my $final_function_name = $function_info[$ref_index]{"routine"}; gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name"); } } if (not $found_a_match) #------------------------------------------------------------------------------ # This should not happen. All we can do is print an error message and stop. #------------------------------------------------------------------------------ { my $msg = "cannot find the index for $routine: found_a_match = "; $msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE"; gp_message ("assertion", $subr_name, $msg); } } #------------------------------------------------------------------------------ # The loop over all function names has completed and @function_index_list # contains the index values into @function_info for the functions. # # All we now need to do is to retrieve the correct field(s) from the array. #------------------------------------------------------------------------------ for my $i (keys @function_index_list) { my $index_for_function = $function_index_list[$i]; push (@final_html_function_block, $function_info[$index_for_function]{"html function block"}); } for my $i (keys @final_html_function_block) { my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]"; gp_message ("debugXL", $subr_name, $txt); } #------------------------------------------------------------------------------ # Since the numbers are right aligned, we know that any difference between the # metric line length and the maximum must be caused by the first column. All # we need to do is to prepend spaces in case of a difference. # # While we have the line with the metric values, we also replace ZZZ by 3 # spaces. #------------------------------------------------------------------------------ for my $i (keys @metric_values) { if (length ($metric_values[$i]) < $max_metrics_length) { my $pad = $max_metrics_length - length ($metric_values[$i]); my $spaces = ""; for my $s (1 .. $pad) { $spaces .= " "; } $metric_values[$i] = $spaces . $metric_values[$i]; } $metric_values[$i] =~ s/ZZZ/ /g; } #------------------------------------------------------------------------------ # Determine the column widths. The start and end index of the words in the # input line are stored in elements 0 and 1 of @word_index_values. # # The assumption made is that the first digit of a metric value on the first # line is left # aligned with the header text. These are the Total values # and other than for some derived metrics, e.g. CPI, should be the largest. # # The positions of the start of the value is what we should then use for the # word "(sort)" to start. # # For example: # # Excl. Excl. CPU Excl. Excl. Excl. Excl. # Total Cycles Instructions Last-Level IPC CPI # CPU sec. sec. Executed Cache Misses # 174.664 179.250 175838403203 1166209617 0.428 2.339 #------------------------------------------------------------------------------ my $foundit_ref; my $foundit; my @index_values = (); my $index_values_ref; #------------------------------------------------------------------------------ # Search for "Excl." in the top row. The metric values are aligned with this # word and we can use it to position "(sort)" in the last header line. # # In @index_values, we store the position(s) of "Excl." in the header line. # If none can be found, an exception is raised because at least one should # be there. # # TBD: Check if this can be done only once. # ------------------------------------------------------------------------------ my $target_keyword = "Excl."; ($foundit_ref, $index_values_ref) = find_keyword_in_string ( \$remaining_part_header, \$target_keyword); $foundit = ${ $foundit_ref }; @index_values = @{ $index_values_ref }; if ($foundit) { for my $i (keys @index_values) { my $txt = "index_values[$i] = $index_values[$i]"; gp_message ("debugXL", $subr_name, $txt); } } else { my $msg = "keyword $target_keyword not found in $remaining_part_header"; gp_message ("assertion", $subr_name, $msg); } # ------------------------------------------------------------------------------ # Compute the number of spaces we need to add between the "(sort)" strings. # # For example: # # 01234567890123456789 # # Excl. Excl. # (sort) (sort) # xxxxxxxx # # The number of spaces required is 14 - 6 = 8. # # The number of spaces to be added is stored in @padding_values. These are # the spaces to be added before the occurrence of "(sort)". This is why the # first padding value is 0. # ------------------------------------------------------------------------------ # ------------------------------------------------------------------------------ # TBD: This needs to be done only once. # ------------------------------------------------------------------------------ my @padding_values = (); my $P_previous = 0; for my $i (keys @index_values) { my $L = $index_values[$i]; my $P = $L + length ("(sort)"); my $pad_spaces = $L - $P_previous; push (@padding_values, $pad_spaces); $P_previous = $P; } for my $i (keys @padding_values) { my $txt = "padding_values[$i] = $padding_values[$i]"; gp_message ("debugXL", $subr_name, $txt); } #------------------------------------------------------------------------------ # Build up the sort line. Mark the current metric and make sure the line is # aligned with the header. #------------------------------------------------------------------------------ my $sort_string = "(sort)"; my $length_sort_string = length ($sort_string); my $sort_line = ""; my @active_metrics = split (":", $summary_metrics); for my $i (0 .. $number_of_metrics-1) { my $pad = $padding_values[$i]; my $metric_value = $active_metrics[$i]; my $spaces = ""; for my $s (1 .. $pad) { $spaces .= " "; } gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad"); if ($metric_value eq $exp_type) #------------------------------------------------------------------------------ # The current metric should have a different background color. #------------------------------------------------------------------------------ { $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . "." . $metric_value . ".html' style='background-color:" . $g_html_color_scheme{"background_selected_sort"} . "\'><b>(sort)</b></a>"; } elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric)) #------------------------------------------------------------------------------ # Set the background color for the sort metric in the main function overview. #------------------------------------------------------------------------------ { $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . "." . $metric_value . ".html' style='background-color:" . $g_html_color_scheme{"background_selected_sort"} . "'><b>(sort)</b></a>"; } else #------------------------------------------------------------------------------ # Do not set a specific background for all other metrics. #------------------------------------------------------------------------------ { $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . "." . $metric_value . ".html'>(sort)</a>"; } #------------------------------------------------------------------------------ # Prepend the spaces to ensure correct alignment with the rest of the header. #------------------------------------------------------------------------------ $sort_line .= $spaces . $sort_string; } push (@header_lines, $sort_line); #------------------------------------------------------------------------------ # Print the final results for the header and metrics. #------------------------------------------------------------------------------ for my $i (keys @header_lines) { gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); } for my $i (keys @metric_values) { gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]"); } #------------------------------------------------------------------------------ # Construct the lines for the function overview. # # TBD: We could eliminate two structures here because metric_values and # final_html_function_block are only copied and the result stored. #------------------------------------------------------------------------------ for my $i (keys @function_names) { push (@metrics_part, $metric_values[$i]); push (@function_view_array, $final_html_function_block[$i]); } for my $i (0 .. $#function_view_array) { my $msg = "function_view_array[$i] = $function_view_array[$i]"; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Element "function table" contains the array with all the function view data. #------------------------------------------------------------------------------ $function_view_structure{"header"} = [@header_lines]; $function_view_structure{"metrics part"} = [@metrics_part]; $function_view_structure{"function table"} = [@function_view_array]; return (\%function_view_structure); } #-- End of subroutine process_function_overview #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub process_metrics { my $subr_name = get_my_name (); my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_; my @sort_fields = @{ $sort_fields_ref }; my %metric_description = %{ $metric_description_ref }; my %ignored_metrics = %{ $ignored_metrics_ref }; my $outputdir = append_forward_slash ($input_string); my $LANG = $g_locale_settings{"LANG"}; my $max_len = 0; my $metric_comment; my ($imetricn,$outfile); my ($html_metrics_record,$imetric,$metric); $html_metrics_record = "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n"; $outfile = $outputdir . "metrics.html"; open (METRICSOUT, ">", $outfile) or die ("$subr_name - unable to open file $outfile for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $outfile for writing"); for $metric (@sort_fields) { $max_len = max ($max_len, length ($metric)); gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len"); } # TBD: Check this # for $imetric (@IMETRICS) for $imetric (keys %ignored_metrics) { $max_len = max ($max_len, length ($imetric)); gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len"); } $max_len++; gp_message ("debug", $subr_name, "max_len = $max_len"); $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">"; for $metric (@sort_fields) { my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; gp_message ("debug", $subr_name, "handling metric metric = $metric->$description"); $html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n"; } # $imetricn = scalar (keys %IMETRICS); $imetricn = scalar (keys %ignored_metrics); if ($imetricn) { $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">"; # for $imetric (sort keys %IMETRICS){ for $imetric (sort keys %ignored_metrics) { $metric_comment = "(inclusive, exclusive, and percentages)"; $html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n"; gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment"); } } print METRICSOUT $html_metrics_record; print METRICSOUT $g_html_credits_line; close (METRICSOUT); gp_message ("debug", $subr_name, "closed metrics file $outfile"); return (0); } #-- End of subroutine process_metrics #------------------------------------------------------------------------------- # TBD #------------------------------------------------------------------------------- sub process_metrics_data { my $subr_name = get_my_name (); my ($outfile1, $outfile2, $ignored_metrics_ref) = @_; my %ignored_metrics = %{ $ignored_metrics_ref }; my %metric_value = (); my %metric_description = (); my %metric_found = (); my $user_metrics; my $system_metrics; my $wall_metrics; my $metric_spec; my $metric_flavor; my $metric_visibility; my $metric_name; my $metric_text; my $metricdata; my $metric_line; my $summary_metrics; my $detail_metrics; my $detail_metrics_system; my $call_metrics; if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") { gp_message ("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"}); # get metrics $summary_metrics=''; $detail_metrics=''; $detail_metrics_system=''; $call_metrics = ''; $user_metrics=0; $system_metrics=0; $wall_metrics=0; my ($last_metric,$metric,$value,$i,$r); open (METRICTOTALS, "<", $outfile2) or die ("Unable to open metric value data file $outfile2 for reading - '$!'"); gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data"); #------------------------------------------------------------------------------ # Below an example of the file that has just been opened. The lines I marked # with a * has been wrapped by my for readability. This is not the case in the # file, but makes for a really long line. # # Also, the data comes from one PC experiment and two HWC experiments. #------------------------------------------------------------------------------ # <Total> # Exclusive Total CPU Time: 32.473 (100.0%) # Inclusive Total CPU Time: 32.473 (100.0%) # Exclusive CPU Cycles: 23.586 (100.0%) # " count: 47054706905 # Inclusive CPU Cycles: 23.586 (100.0%) # " count: 47054706905 # Exclusive Instructions Executed: 54417033412 (100.0%) # Inclusive Instructions Executed: 54417033412 (100.0%) # Exclusive Last-Level Cache Misses: 252730685 (100.0%) # Inclusive Last-Level Cache Misses: 252730685 (100.0%) # * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: # * Exclusive Cycles Per Instruction: # * Inclusive Cycles Per Instruction: # * Size: 0 # PC Address: 1:0x00000000 # Source File: (unknown) # Object File: (unknown) # Load Object: <Total> # Mangled Name: # Aliases: #------------------------------------------------------------------------------ while (<METRICTOTALS>) { $metricdata = $_; chomp ($metricdata); gp_message ("debug", $subr_name, "file metrictotals: $metricdata"); #------------------------------------------------------------------------------ # Ignoring whitespace, search for any line with a ":" in it, followed by # a number with or without a dot. So, an integer or floating-point number. #------------------------------------------------------------------------------ if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/) { gp_message ("debug", $subr_name, " candidate => $metricdata"); $metric = $1; $value = $2; if ( ($metric eq "PC Address") or ($metric eq "Size")) { gp_message ("debug", $subr_name, " skipped => $metric $value"); next; } gp_message ("debug", $subr_name, " proceed => $metric $value"); if ($metric eq '" count') #------------------------------------------------------------------------------ # Hardware counter experiments have this info. Note that this line is not the # first one to be encountered, so $last_metric has been defined already. #------------------------------------------------------------------------------ { $metric = $last_metric." Count"; # we presume ....... gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric"); } $i=index ($metricdata,":"); $r=rindex ($metricdata,":"); gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r"); if ($i == $r) { if ($value > 0) # Not interested in metrics contributing zero { $metric_value{$metric} = $value; gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}"); # e.g. $metric_value{Exclusive Total Thread Time} = 302.562 # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484 } } else #------------------------------------------------------------------------------ # TBD This code deals with an old bug and may be removed. #------------------------------------------------------------------------------ { # er_print bug - e.g. # Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%) gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-"); $r=rindex ($metricdata,":",$r-1); if ($r == -1) { # ignore gp_message ("debug", $subr_name, "metrictotals odd line ignored<-"); $last_metric = "foo"; next; } my ($good_part)=substr ($metricdata,$r+1); if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/) { $metric = $1; $value = $2; if ($value>0) # Not interested in metrics contributing zero { $metric_value{$metric} = $value; my $msg = "metrictotals odd line rescued '$metric'=$value"; gp_message ("debug", $subr_name, $msg); } } } #------------------------------------------------------------------------------ # Preserve the current metric. #------------------------------------------------------------------------------ $last_metric = $metric; } } close (METRICTOTALS); } if (scalar (keys %metric_value) == 0) #------------------------------------------------------------------------------ # If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we # blow up later. # # TBD: See if this can be handled differently. #------------------------------------------------------------------------------ { $metric_value{"Exclusive Total CPU Time"} = 0; gp_message ("debug", $subr_name, "no metrics found and a stub was added"); } for my $metric (sort keys %metric_value) { gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}"); } gp_message ("debug", $subr_name, "proceed to process file $outfile1"); #------------------------------------------------------------------------------ # Open and process the metrics file. #------------------------------------------------------------------------------ open (METRICS, "<", $outfile1) or die ("Unable to open metrics file $outfile1: '$!'"); gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); #------------------------------------------------------------------------------ # Parse the file. This is a typical example: # # Exp Sel Total # === === ===== # 1 all 2 # 2 all 1 # 3 all 2 # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) # Available metrics: # Exclusive Total CPU Time: e.%totalcpu # Inclusive Total CPU Time: i.%totalcpu # Exclusive CPU Cycles: e.+%cycles # Inclusive CPU Cycles: i.+%cycles # Exclusive Instructions Executed: e+%insts # Inclusive Instructions Executed: i+%insts # Exclusive Last-Level Cache Misses: e+%llm # Inclusive Last-Level Cache Misses: i+%llm # Exclusive Instructions Per Cycle: e+IPC # Inclusive Instructions Per Cycle: i+IPC # Exclusive Cycles Per Instruction: e+CPI # Inclusive Cycles Per Instruction: i+CPI # Size: size # PC Address: address # Name: name #------------------------------------------------------------------------------ while (<METRICS>) { $metric_line = $_; chomp ($metric_line); gp_message ("debug", $subr_name, "processing line $metric_line"); #------------------------------------------------------------------------------ # The original regex has bugs because the line should not be allowed to start # with a ":". So this is wrong: # if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) # # This is better: # if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) # # In general, this regex has some potential issues and has been replaced by # the one shown below. # # We select a line that does not start with "Current" and aside from whitespace # starts with anything (although it should be a string with words only), # followed by whitespace and either an "e" or "i". This is called the "flavor" # and is followed by a visibility marker (.,+,%, or !) and a metric name. #------------------------------------------------------------------------------ # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = extract_metric_specifics ($metric_line); # if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) if ($metric_spec eq "skipped") { gp_message ("debug", $subr_name, "skipped line: $metric_line"); } else { gp_message ("debug", $subr_name, "line of interest: $metric_line"); $metric_found{$metric_spec} = 1; if ($g_user_settings{"ignore_metrics"}{"defined"}) { gp_message ("debug", $subr_name, "check for $metric_spec"); if (exists ($ignored_metrics{$metric_name})) { gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name"); next; } } #------------------------------------------------------------------------------ # This metric is not on the ignored list and qualifies, so store it. #------------------------------------------------------------------------------ $metric_description{$metric_spec} = $metric_text; # TBD: add for other visibilities too, like + gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}"); if ($metric_flavor ne "e") { gp_message ("debug", $subr_name, "metric $metric_spec is ignored"); } else #------------------------------------------------------------------------------ # Only the exclusive metrics are shown. #------------------------------------------------------------------------------ { gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered"); if ($metric_spec =~ /user/) { $user_metrics = $TRUE; gp_message ("debug", $subr_name, "m: user_metrics set to TRUE"); } elsif ($metric_spec =~ /system/) { $system_metrics = $TRUE; gp_message ("debug", $subr_name, "m: system_metrics set to TRUE"); } elsif ($metric_spec =~ /wall/) { $wall_metrics = $TRUE; gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE"); } #------------------------------------------------------------------------------ # TBD I don't see why these need to be skipped. Also, should be totalcpu. #------------------------------------------------------------------------------ elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/)) { # skip total thread time and total CPU time gp_message ("debug", $subr_name, "m: skip above"); } elsif (defined ($metric_value{$metric_text})) { gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}"); if ($summary_metrics ne '') { $summary_metrics = $summary_metrics.':'.$metric_spec; gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1"); if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) { $detail_metrics = $detail_metrics.':'.$metric_spec; gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1"); $detail_metrics_system = $detail_metrics_system.':'.$metric_spec; gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1"); } else { gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); } } else { $summary_metrics = $metric_spec; gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2"); if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) { $detail_metrics = $metric_spec; gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2"); $detail_metrics_system = $metric_spec; gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2"); } else { gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); } } gp_message ("debug", $subr_name, " metric $metric_spec added"); } else { gp_message ("debug", $subr_name, "m: no want above metric was a 0 total"); } } } } close METRICS; if ($wall_metrics > 0) { gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics"); $summary_metrics = "e.wall:".$summary_metrics; gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3"); } if ($system_metrics > 0) { gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system"); $summary_metrics = "e.system:".$summary_metrics; $call_metrics = "i.system:".$call_metrics; $detail_metrics_system ='e.system:'.$detail_metrics_system; gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4"); gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics"); gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3"); } #------------------------------------------------------------------------------ # TBD: e.user and i.user do not always exist!! #------------------------------------------------------------------------------ if ($user_metrics > 0) { gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics"); # Ruud if (!exists ($IMETRICS{"i.user"})){ if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) { $summary_metrics = "e.user:".$summary_metrics; } else { $summary_metrics = "e.user:i.user:".$summary_metrics; } $detail_metrics = "e.user:".$detail_metrics; $detail_metrics_system = "e.user:".$detail_metrics_system; gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5"); gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3"); gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4"); if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) { $call_metrics = "a.user:".$call_metrics; } else { $call_metrics = "a.user:i.user:".$call_metrics; } gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2"); } if ($call_metrics eq "") { $call_metrics = $detail_metrics; gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics "); gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3"); } for my $metric (sort keys %ignored_metrics) { if ($ignored_metrics{$metric}) { gp_message ("debug", $subr_name, "active metric, but ignored: $metric"); } } return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); } #-- End of subroutine process_metrics_data #------------------------------------------------------------------------------ # Process source lines that are not part of the target function. # # Generate straightforward HTML, but define an anchor based on the source line # number in the list. #------------------------------------------------------------------------------ sub process_non_target_source { my $subr_name = get_my_name (); my ($start_scan, $end_scan, $src_times_regex, $function_regex, $number_of_metrics, $file_contents_ref, $modified_html_ref) = @_; my @file_contents = @{ $file_contents_ref }; my @modified_html = @{ $modified_html_ref }; my $colour_code_line = $FALSE; my $input_line; my $line_id; my $modified_line; #------------------------------------------------------------------------------ # Main loop to parse all of the source code and take action as needed. #------------------------------------------------------------------------------ for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++) { $input_line = $file_contents[$line_no]; #------------------------------------------------------------------------------ # Generate straightforward HTML, but define an anchor based on the source line # number in the list. #------------------------------------------------------------------------------ $line_id = extract_source_line_number ($src_times_regex, $function_regex, $number_of_metrics, $input_line); if ($input_line =~ /$function_regex/) { $colour_code_line = $TRUE; } #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; #------------------------------------------------------------------------------ # Add an id. #------------------------------------------------------------------------------ $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; my $coloured_line; if ($colour_code_line) { my $boldface = $TRUE; $coloured_line = color_string ( $input_line, $boldface, $g_html_color_scheme{"non_target_function_name"}); $colour_code_line = $FALSE; $modified_line .= "$coloured_line"; } else { $modified_line .= "$input_line"; } gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line"); push (@modified_html, $modified_line); } return (\@modified_html); } #-- End of subroutine process_non_target_source #------------------------------------------------------------------------------ # This function scans the configuration file and adapts the internal settings # accordingly. # # Errors are stored during the parsing and processing phase. They are printed # at the end and sorted by line number. #------------------------------------------------------------------------------ sub process_rc_file { my $subr_name = get_my_name (); my ($rc_file_name, $rc_file_paths_ref) = @_; #------------------------------------------------------------------------------ # Local structures. #------------------------------------------------------------------------------ my %rc_settings_user = (); #-- Store the values extracted from the config file my %error_and_warning_msgs = (); my @rc_file_paths = (); my @split_line; my @my_fields; my $message; my $first_part; my $line; my $line_number; my $number_of_fields; my $number_of_paths; my $parse_errors; #-- Count the number of errors my $parse_warnings; #-- Count the number of errors my $rc_config_file; my $rc_file_found; my $rc_keyword; my $rc_value; @rc_file_paths = @{$rc_file_paths_ref}; $number_of_paths = scalar (@rc_file_paths); if ($number_of_paths == 0) #------------------------------------------------------------------------------ # This should not happen, but is a good safety net to add. #------------------------------------------------------------------------------ { my $msg = "search path list is empty"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check for the presence of a configuration file. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"); $rc_file_found = $FALSE; for my $path_name (@rc_file_paths) { $rc_config_file = $path_name . "/" . $rc_file_name; gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file"); if (-f $rc_config_file) { gp_message ("debug", $subr_name, "found configuration file $rc_config_file"); $rc_file_found = $TRUE; last; } } if (not $rc_file_found) #------------------------------------------------------------------------------ # There is no configuration file and we can skip this subroutine. #------------------------------------------------------------------------------ { gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found"); return (0); } else { open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file") or die ("$subr_name - unable to open file $rc_config_file for reading: $!"); #------------------------------------------------------------------------------ # The configuration file has been opened for reading. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading"); } gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file"); gp_message ("debug", $subr_name, "processing configuration file $rc_config_file"); #------------------------------------------------------------------------------ # Here we scan the configuration file for the settings. # # A setting consists of a keyword, optionally followed by a value. It is # optional because not all keywords may require a value. # # At the end of this block, all keyword/value pairs are stored in a hash. # # We do not yet check for the validity of these pairs. This is done next. # # The original code had this all integrated, but it made the code very # complex with deeply nested if-statements. The flow was also hard to follow. #------------------------------------------------------------------------------ $parse_errors = 0; $parse_warnings = 0; $line_number = 0; while (my $line = <GP_DISPLAY_HTML_RC>) { chomp ($line); $line_number++; gp_message ("debug", $subr_name, "read input line = $line"); #------------------------------------------------------------------------------ # Ignore a line with whitespace only #------------------------------------------------------------------------------ if ($line =~ /^\s*$/) { gp_message ("debug", $subr_name, "ignored a line with whitespace"); next; } #------------------------------------------------------------------------------ # Ignore a comment line, defined by starting with a "#", possibly prepended by # whitespace. #------------------------------------------------------------------------------ if ($line =~ /^\s*\#/) { gp_message ("debug", $subr_name, "ignored a full comment line"); next; } #------------------------------------------------------------------------------ # Split the input line using the "#" symbol as a separator. We have already # handled the case of an isolated comment line, so there may only be an # embedded comment. # # Regardless of this, we are only interested in the first part. #------------------------------------------------------------------------------ @split_line = split ("#", $line); for my $i (@split_line) { gp_message ("debug", $subr_name, "elements after split of line: $i"); } $first_part = $split_line[0]; gp_message ("debug", $subr_name, "relevant part = $first_part"); if ($first_part =~ /[&\^\*\@\$]+/) #------------------------------------------------------------------------------ # The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error # an fetch the next line. #------------------------------------------------------------------------------ { $parse_errors++; $message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; next; } else #------------------------------------------------------------------------------ # Split the first part on whitespace and verify the number of fields to be # valid. Although we currently only have keywords with a value, a keyword # without value is supported to. # # If the number of fields is valid, the keyword and value are stored. In case # of a single field, the value is assigned a special string. # # Although this situation should not occur, we do abort if something unexpected # is encountered here. #------------------------------------------------------------------------------ { @my_fields = split (/\s/, $split_line[0]); $number_of_fields = scalar (@my_fields); gp_message ("debug", $subr_name, "number of fields = $number_of_fields"); } if ($number_of_fields ge 3) #------------------------------------------------------------------------------ # This is not supported. #------------------------------------------------------------------------------ { $parse_errors++; $message = "more than 2 fields found: $first_part"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; next; } elsif ($number_of_fields eq 2) { $rc_keyword = $my_fields[0]; $rc_value = $my_fields[1]; } elsif ($number_of_fields eq 1) { $rc_keyword = $my_fields[0]; $rc_value = "the_field_is_empty"; } else { my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Store the keyword, value and line number. #------------------------------------------------------------------------------ if (exists ($rc_settings_user{$rc_keyword})) { $parse_warnings++; my $prev_value = $rc_settings_user{$rc_keyword}{"value"}; my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"}; if ($rc_value ne $prev_value) { $message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'"; } else { $message = "option $rc_keyword previously set to the same value at line $prev_line_number"; } $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message; } $rc_settings_user{$rc_keyword}{"value"} = $rc_value; $rc_settings_user{$rc_keyword}{"line_no"} = $line_number; gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); gp_message ("debug", $subr_name, "stored value = $rc_value"); gp_message ("debug", $subr_name, "stored line number = $line_number"); } #------------------------------------------------------------------------------ # Completed the parsing of the configuration file. It can be closed. #------------------------------------------------------------------------------ close (GP_DISPLAY_HTML_RC); #------------------------------------------------------------------------------ # Print the raw input as just collected from the configuration file. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "contents of %rc_settings_user:"); for my $keyword (keys %rc_settings_user) { my $key_value = $rc_settings_user{$keyword}{"value"}; gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value"); } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); } } #------------------------------------------------------------------------------ # We are almost done. Check for all keywords found whether they are valid. # Also verify that the corresponding value is valid. # # Update the g_user_settings table if everything is okay. #------------------------------------------------------------------------------ for my $rc_keyword (keys %rc_settings_user) { my $rc_value = $rc_settings_user{$rc_keyword}{"value"}; if (exists ( $g_user_settings{$rc_keyword})) { #------------------------------------------------------------------------------ # This is a supported keyword. There are two more things left to do: # - Check how many values it requires (currently exactly one is supported) # - Is the value a valid number or string? #------------------------------------------------------------------------------ my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; if ($no_of_arguments eq 1) { my $input_value = $rc_value; if ($input_value ne "the_field_is_empty") # #------------------------------------------------------------------------------ # So far, so good. We only need to check if the value is valid for the keyword. #------------------------------------------------------------------------------ { my $data_type = $g_user_settings{$rc_keyword}{"data_type"}; my $valid_input = verify_if_input_is_valid ($input_value, $data_type); #------------------------------------------------------------------------------ # Check if the value is valid. #------------------------------------------------------------------------------ if ($valid_input) { $g_user_settings{$rc_keyword}{"current_value"} = $rc_value; $g_user_settings{$rc_keyword}{"defined"} = $TRUE; } else { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; $message = "input value '$input_value' for keyword $rc_keyword is not valid"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; next; } } else #------------------------------------------------------------------------------ # This keyword requires a value, but none has been found. #------------------------------------------------------------------------------ { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; $message = "missing value for keyword '$rc_keyword'"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; next; } } elsif ($no_of_arguments eq 0) #------------------------------------------------------------------------------ # Currently a theoretical scenario since all commands require a value, but in # case this is no longer true, we need to at least flag the fact the user set # this command. #------------------------------------------------------------------------------ { $g_user_settings{$rc_keyword}{"defined"} = $TRUE; } else #------------------------------------------------------------------------------ # The code is not prepared for the situation one command has multiple values, # but this situation should never occur. Still it won't hurt to add a check. #------------------------------------------------------------------------------ { my $msg = "cannot handle $no_of_arguments in the input"; gp_message ("assertion", $subr_name, $msg); } } else #------------------------------------------------------------------------------ # A non-valid keyword is found. This is flagged as an error. #------------------------------------------------------------------------------ { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; $message = "keyword $rc_keyword is not supported"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; } } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); } } print_table_user_settings ("debug", "upon the return from $subr_name"); if ( ($parse_errors == 0) and ($parse_warnings == 0) ) { gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file"); } else { if ($parse_errors > 0) { my $plural_or_single = ($parse_errors > 1) ? "errors" : "error"; $message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:"; gp_message ("debug", $subr_name, $message); #------------------------------------------------------------------------------ # Sort the hash keys, the line numbers, alphabetically and print the # corresponding error messages. #------------------------------------------------------------------------------ for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} })) { $message = $g_error_keyword. "[line $line_no] in file $rc_config_file - "; $message .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; gp_message ("debug", $subr_name, $message); } } if (not $g_quiet) { if ($parse_warnings > 0) { $message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:"; gp_message ("debug", $subr_name, $message); for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} })) { $message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - "; $message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; gp_message ("debug", $subr_name, $message); } } } } return ($parse_errors); } #-- End of subroutine process_rc_file #------------------------------------------------------------------------------ # Generate the annotated html file for the source listing. #------------------------------------------------------------------------------ sub process_source { my $subr_name = get_my_name (); my ($number_of_metrics, $function_info_ref, $outputdir, $input_filename) = @_; my @function_info = @{ $function_info_ref }; #------------------------------------------------------------------------------ # The regex section #------------------------------------------------------------------------------ my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)'; my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>'; my $function_regex = '^(\s*)<Function:\s(.*)>'; my $function2_regex = '^(\s*)<Function:\s(.*)>'; my $src_regex = '(\s*)(\d+)\.(.*)'; my $txt_ext_regex = '\.txt$'; my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$'; my $integer_only_regex = '\d+'; #------------------------------------------------------------------------------ # Computed dynamically below. # TBD: Try to move this up. #------------------------------------------------------------------------------ my $src_times_regex; my $hot_lines_regex; my $metric_regex; my $metric_extra_regex; my @components = (); my @fields_in_line = (); my @file_contents = (); my @hot_source_lines = (); my @max_metric_values = (); my @modified_html = (); my @transposed_hot_lines = (); my $colour_coded_line; my $colour_coded_line_ref; my $line_id; my $ignore_value; my $func_name_in_src_file; my $html_new_line = "<br>"; my $input_line; my $metric_values; my $modified_html_ref; my $modified_line; my $is_empty; my $start_all_source; my $start_target_source; my $end_target_source; my $output_line; my $hot_line; my $src_line_no; my $src_code_line; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; my $file_title; my $found_target; my $html_dis_record; my $html_end; my $html_header; my $html_home; my $rounded_percentage; my $start_tracking; my $threshold_line; my $base; my $boldface; my $msg; my $routine; my $LANG = $g_locale_settings{"LANG"}; my $the_title = set_title ($function_info_ref, $input_filename, "process source"); my $outfile = $input_filename . ".html"; #------------------------------------------------------------------------------ # Remove the .txt from file.<n>.src.txt #------------------------------------------------------------------------------ my $html_output_file = $input_filename; $html_output_file =~ s/$txt_ext_regex/.html/; gp_message ("debug", $subr_name, "input_filename = $input_filename"); gp_message ("debug", $subr_name, "the_title = $the_title"); $file_title = $the_title; $html_header = ${ create_html_header (\$file_title) }; $html_home = ${ generate_home_link ("right") }; push (@modified_html, $html_header); push (@modified_html, $html_home); push (@modified_html, "<pre>"); #------------------------------------------------------------------------------ # Open the html file used for the output. #------------------------------------------------------------------------------ open (NEW_HTML, ">", $html_output_file) or die ("$subr_name - unable to open file $html_output_file for writing: '$!'"); gp_message ("debug", $subr_name , "opened file $html_output_file for writing"); $base = get_basename ($input_filename); gp_message ("debug", $subr_name, "base = $base"); if ($base =~ /$src_filename_id_regex/) { my $file_id = $1; if (defined ($function_info[$file_id]{"routine"})) { $routine = $function_info[$file_id]{"routine"}; gp_message ("debugXL", $subr_name, "target routine = $routine"); } else { my $msg = "cannot retrieve routine name for file_id = $file_id"; gp_message ("assertion", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Check if the input file is empty. If so, generate a short text in the html # file and return. Otherwise open the file and read the contents. #------------------------------------------------------------------------------ $is_empty = is_file_empty ($input_filename); if ($is_empty) { #------------------------------------------------------------------------------ # The input file is empty. Write a diagnostic message in the html file and exit. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name ,"file $input_filename is empty"); my $comment = "No source listing generated by $tool_name - " . "file $input_filename is empty"; my $error_file = $outputdir . "gp-listings.err"; my $html_empty_file_ref = html_text_empty_file (\$comment, \$error_file); my @html_empty_file = @{ $html_empty_file_ref }; print NEW_HTML "$_\n" for @html_empty_file; close NEW_HTML; return (0); } else #------------------------------------------------------------------------------ # Open the input file with the source code #------------------------------------------------------------------------------ { open (SRC_LISTING, "<", $input_filename) or die ("$subr_name - unable to open file $input_filename for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $input_filename for reading"); } #------------------------------------------------------------------------------ # Generate the regex for the metrics. This depends on the number of metrics. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator<--"); $metric_regex = ''; $metric_extra_regex = ''; for my $metric_used (1 .. $number_of_metrics) { $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; } $metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')'; $hot_lines_regex = '^(#{2})\s+'; $hot_lines_regex .= '('.$metric_regex.')'; $hot_lines_regex .= '([0-9?]+)\.\s+(.*)'; $src_times_regex = '^(#{2}|\s{2})\s+'; $src_times_regex .= '('.$metric_extra_regex.')'; $src_times_regex .= '(.*)'; gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); gp_message ("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex"); gp_message ("debugXL", $subr_name, "src_times_regex = $src_times_regex"); gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); gp_message ("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex"); gp_message ("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex"); gp_message ("debugXL", $subr_name, "function_regex = $function_regex"); gp_message ("debugXL", $subr_name, "function2_regex = $function2_regex"); gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); #------------------------------------------------------------------------------ # Read the file into memory. #------------------------------------------------------------------------------ chomp (@file_contents = <SRC_LISTING>); #------------------------------------------------------------------------------ # Identify the header lines. Make the minimal assumptions. # # In both cases, the first line after the header has whitespace. This is # followed by either one of the following: # # - <line_no>. # - <Function: # # These are the characteristics we use below. #------------------------------------------------------------------------------ for (my $line_number=0; $line_number <= $#file_contents; $line_number++) { $input_line = $file_contents[$line_number]; #------------------------------------------------------------------------------ # We found the first source code line. Bail out. #------------------------------------------------------------------------------ if (($input_line =~ /$end_src1_header_regex/) or ($input_line =~ /$end_src2_header_regex/)) { gp_message ("debugXL", $subr_name, "header time is over - hit source line"); gp_message ("debugXL", $subr_name, "line_number = $line_number"); gp_message ("debugXL", $subr_name, "input_line = $input_line"); last; } else #------------------------------------------------------------------------------ # Store the header lines in the html structure. #------------------------------------------------------------------------------ { $modified_line = "<i>" . $input_line . "</i>"; push (@modified_html, $modified_line); } } #------------------------------------------------------------------------------ # We know the source code starts at this index value: #------------------------------------------------------------------------------ $start_all_source = scalar (@modified_html); gp_message ("debugXL", $subr_name, "source starts at start_all_source = $start_all_source"); #------------------------------------------------------------------------------ # Scan the file to identify where the target source starts and ends. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "search for target function $routine"); $start_tracking = $FALSE; $found_target = $FALSE; for (my $line_number=0; $line_number <= $#file_contents; $line_number++) { $input_line = $file_contents[$line_number]; gp_message ("debugXL", $subr_name, "[$line_number] $input_line"); if ($input_line =~ /$function_regex/) { if (defined ($1) and defined ($2)) { $func_name_in_src_file = $2; my $msg = "found a function - name = $func_name_in_src_file"; gp_message ("debugXL", $subr_name, $msg); if ($start_tracking) { $start_tracking = $FALSE; $end_target_source = $line_number - 1; my $msg = "end_target_source = $end_target_source"; gp_message ("debugXL", $subr_name, $msg); last; } if ($func_name_in_src_file eq $routine) { $found_target = $TRUE; $start_tracking = $TRUE; $start_target_source = $line_number; gp_message ("debugXL", $subr_name, "found target function $routine"); gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine"); gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); } } else { my $msg = "parsing line $input_line"; gp_message ("assertion", $subr_name, $msg); } } } #------------------------------------------------------------------------------ # This is not supposed to happen, but it is not a fatal error either. The # hyperlinks related to this function will not work, so a warning is issued. # A message is issued both in debug mode, and as a warning. #------------------------------------------------------------------------------ if (not $found_target) { my $msg; gp_message ("debug", $subr_name, "target function $routine not found"); $msg = "function $routine not found in $base - " . "links to source code involving this function will not work"; gp_message ("warning", $subr_name, $msg); return ($found_target); } #------------------------------------------------------------------------------ # Catch the line number of the last function. #------------------------------------------------------------------------------ if ($start_tracking) { $end_target_source = $#file_contents; } gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source"); #------------------------------------------------------------------------------ # We now have the index range for the function of interest and will parse it. # Since we already handled the first line with the function marker, we start # with the line following. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Find the hot source lines and store them. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "determine the maximum metric values"); for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++) { $input_line = $file_contents[$line_number]; gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line"); if ( $input_line =~ /$hot_lines_regex/ ) { gp_message ("debugXL", $subr_name, " $line_number : found a hot line"); #------------------------------------------------------------------------------ # We found a hot line and the metric fields are stored in $2. We turn this # string into an array and add it as a row to hot_source_lines. #------------------------------------------------------------------------------ $hot_line = $1; $metric_values = $2; gp_message ("debugXL", $subr_name, "hot_line = $hot_line"); gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); my @metrics = split (" ", $metric_values); push (@hot_source_lines, [@metrics]); } gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line"); } #------------------------------------------------------------------------------ # Transpose the array with the hot lines. This means each row has all the # values for a metrict and it makes it easier to determine the maximum values. #------------------------------------------------------------------------------ for my $row (keys @hot_source_lines) { my $msg = "row[" . $row . "] = "; for my $col (keys @{$hot_source_lines[$row]}) { $msg .= "$hot_source_lines[$row][$col] "; $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col]; } } #------------------------------------------------------------------------------ # Print the maximum metric values found. Each row contains the data for a # different metric. #------------------------------------------------------------------------------ for my $row (keys @transposed_hot_lines) { my $msg = "row[" . $row . "] = "; for my $col (keys @{$transposed_hot_lines[$row]}) { $msg .= "$transposed_hot_lines[$row][$col] "; } gp_message ("debugXL", $subr_name, "hot lines = $msg"); } #------------------------------------------------------------------------------ # Determine the maximum value for each metric. #------------------------------------------------------------------------------ for my $row (keys @transposed_hot_lines) { my $max_val = 0; for my $col (keys @{$transposed_hot_lines[$row]}) { $max_val = max ($transposed_hot_lines[$row][$col], $max_val); } #------------------------------------------------------------------------------ # Convert to a floating point number. #------------------------------------------------------------------------------ if ($max_val =~ /$integer_only_regex/) { $max_val = sprintf ("%f", $max_val); } push (@max_metric_values, $max_val); } for my $metric (keys @max_metric_values) { my $msg = "$input_filename max_metric_values[$metric] = " . $max_metric_values[$metric]; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Process those functions that are not the current target. #------------------------------------------------------------------------------ $modified_html_ref = process_non_target_source ($start_all_source, $start_target_source-1, $src_times_regex, $function_regex, $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; #------------------------------------------------------------------------------ # This is the core part to process the information for the target function. #------------------------------------------------------------------------------ gp_message ("debugXL", $subr_name, "parse and process the target source"); $modified_html_ref = process_target_source ($start_target_source, $end_target_source, $routine, \@max_metric_values, $src_times_regex, $function2_regex, $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; if ($end_target_source < $#file_contents) { $modified_html_ref = process_non_target_source ($end_target_source+1, $#file_contents, $src_times_regex, $function_regex, $number_of_metrics, \@file_contents, \@modified_html); @modified_html = @{ $modified_html_ref }; } gp_message ("debug", $subr_name, "completed reading source"); #------------------------------------------------------------------------------ # Add an extra line with diagnostics. # # TBD: The same is done in generate_dis_html but should be done only once. #------------------------------------------------------------------------------ if ($hp_value > 0) { my $rounded_percentage = sprintf ("%.1f", $hp_value); $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; } else { $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; } $html_home = ${ generate_home_link ("left") }; $html_end = ${ terminate_html_document () }; push (@modified_html, "</pre>"); push (@modified_html, "<br>"); push (@modified_html, $threshold_line); push (@modified_html, $html_home); push (@modified_html, "<br>"); push (@modified_html, $g_html_credits_line); push (@modified_html, $html_end); for my $i (0 .. $#modified_html) { gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); } #------------------------------------------------------------------------------ # Write the generated HTML text to file. #------------------------------------------------------------------------------ for my $i (0 .. $#modified_html) { print NEW_HTML "$modified_html[$i]" . "\n"; } close (NEW_HTML); close (SRC_LISTING); return ($found_target); } #-- End of subroutine process_source #------------------------------------------------------------------------------ # Process the source lines for the target function. #------------------------------------------------------------------------------ sub process_target_source { my $subr_name = get_my_name (); my ($start_scan, $end_scan, $target_function, $max_metric_values_ref, $src_times_regex, $function2_regex, $number_of_metrics, $file_contents_ref, $modified_html_ref) = @_; my @file_contents = @{ $file_contents_ref }; my @modified_html = @{ $modified_html_ref }; my @max_metric_values = @{ $max_metric_values_ref }; my @components = (); my $colour_coded_line; my $colour_coded_line_ref; my $hot_line; my $input_line; my $line_id; my $modified_line; my $metric_values; my $src_code_line; my $src_line_no; gp_message ("debug", $subr_name, "parse and process the core loop"); for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++) { $input_line = $file_contents[$line_number]; #------------------------------------------------------------------------------ # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; $line_id = extract_source_line_number ($src_times_regex, $function2_regex, $number_of_metrics, $input_line); gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id"); if ($input_line =~ /$function2_regex/) #------------------------------------------------------------------------------ # Found the function marker. #------------------------------------------------------------------------------ { if (defined ($1) and defined ($2)) { my $func_name_in_file = $2; my $spaces = $1; my $boldface = $TRUE; gp_message ("debug", $subr_name, "function_name = $2"); my $function_line = "<Function: " . $func_name_in_file . ">"; my $color_function_name = color_string ( $function_line, $boldface, $g_html_color_scheme{"target_function_name"}); my $ftag; if (exists ($g_function_tag_id{$target_function})) { $ftag = $g_function_tag_id{$target_function}; gp_message ("debug", $subr_name, "target_function = $target_function ftag = $ftag"); } else { my $msg = "no ftag found for $target_function"; gp_message ("assertion", $subr_name, $msg); } $modified_line = "<a id=\"" . $ftag . "\"></a>"; $modified_line .= $spaces . "<i>" . $color_function_name . "</i>"; } } elsif ($input_line =~ /$src_times_regex/) #------------------------------------------------------------------------------ # This is a line with metric values. #------------------------------------------------------------------------------ { gp_message ("debug", $subr_name, "input line has metrics"); $hot_line = $1; $metric_values = $2; $src_line_no = $3; $src_code_line = $4; gp_message ("debug", $subr_name, "hot_line = $hot_line"); gp_message ("debug", $subr_name, "metric_values = $metric_values"); gp_message ("debug", $subr_name, "src_line_no = $src_line_no"); gp_message ("debug", $subr_name, "src_code_line = $src_code_line"); if ($hot_line eq "##") #------------------------------------------------------------------------------ # Highlight the most expensive line. #------------------------------------------------------------------------------ { @components = split (" ", $input_line, 1+$number_of_metrics+2); $modified_line = set_background_color_string ( $input_line, $g_html_color_scheme{"background_color_hot"}); } else { #------------------------------------------------------------------------------ # Highlight those lines close enough to the most expensive line. #------------------------------------------------------------------------------ @components = split (" ", $input_line, $number_of_metrics + 2); for my $i (0 .. $number_of_metrics-1) { gp_message ("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]"); } $colour_coded_line_ref = check_metric_values ($metric_values, \@max_metric_values); $colour_coded_line = $ {$colour_coded_line_ref}; if ($colour_coded_line) { gp_message ("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line"); $modified_line = set_background_color_string ($input_line, $g_html_color_scheme{"background_color_lukewarm"}); } else { $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; $modified_line .= "$input_line"; } } } else #------------------------------------------------------------------------------ # This is a regular line that is not modified. #------------------------------------------------------------------------------ { #------------------------------------------------------------------------------ # Add an id. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "$line_number : input line is a regular line"); $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; $modified_line .= "$input_line"; } gp_message ("debug", $subr_name, "$line_number : mod = $modified_line"); push (@modified_html, $modified_line); } return (\@modified_html); } #-- End of subroutine process_target_source #------------------------------------------------------------------------------ # Process the options. Set associated variables and check the options for # correctness. For example, detect if conflicting options have been set. #------------------------------------------------------------------------------ sub process_user_options { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my %ignored_metrics = (); my $error_code; my $message; my $outputdir; my $target_cmd; my $rm_output_msg; my $mkdir_output_msg; my $time_percentage_multiplier; my $process_all_functions; my $option_errors = 0; #------------------------------------------------------------------------------ # The -o and -O options are mutually exclusive. #------------------------------------------------------------------------------ my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; my $dir_o_option = $g_user_settings{"output"}{"current_value"}; my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"}; if ($define_new_output_dir and $overwrite_output_dir) { my $msg; $msg = "the -o/--output and -O/--overwrite options are both set, " . "but are mutually exclusive"; push (@g_user_input_errors, $msg); $msg = "(setting for -o = $dir_o_option, " . "setting for -O = $dir_O_option)"; push (@g_user_input_errors, $msg); $option_errors++; } #------------------------------------------------------------------------------ # Define the quiet mode. While this is an on/off keyword in the input, we # use a boolean in the remainder, because it reads easier. #------------------------------------------------------------------------------ my $quiet_value = $g_user_settings{"quiet"}{"current_value"}; $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE; #------------------------------------------------------------------------------ # In quiet mode, all verbose, warnings and debug messages are suppressed. #------------------------------------------------------------------------------ if ($g_quiet) { $g_user_settings{"verbose"}{"current_value"} = "off"; $g_user_settings{"warnings"}{"current_value"} = "off"; $g_user_settings{"debug"}{"current_value"} = "off"; $g_verbose = $FALSE; $g_warnings = $FALSE; my $debug_off = "off"; my $ignore_value = set_debug_size (\$debug_off); } else { #------------------------------------------------------------------------------ # Get the verbose mode. #------------------------------------------------------------------------------ my $verbose_value = $g_user_settings{"verbose"}{"current_value"}; $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE; #------------------------------------------------------------------------------ # Get the warning mode. #------------------------------------------------------------------------------ my $warning_value = $g_user_settings{"warnings"}{"current_value"}; $g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE; } #------------------------------------------------------------------------------ # The value for HP should be in the interval (0,100]. We already enforced # the number to be positive, but the limits have not been checked yet. #------------------------------------------------------------------------------ my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; if (($hp_value < 0) or ($hp_value > 100)) { my $msg = "the value for the highlight percentage is set to $hp_value, "; $msg .= "but must be in the range [0, 100]"; push (@g_user_input_errors, $msg); $option_errors++; } #------------------------------------------------------------------------------ # The value for TP should be in the interval (0,100]. We already enforced # the number to be positive, but the limits have not been checked yet. #------------------------------------------------------------------------------ my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"}; if (($tp_value < 0) or ($tp_value > 100)) { my $msg = "the value for the total percentage is set to $tp_value, " . "but must be in the range (0, 100]"; push (@g_user_input_errors, $message); $option_errors++; } else { $time_percentage_multiplier = $tp_value/100.0; # Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.) if ($tp_value == 100) { $process_all_functions = $TRUE; # ensure that all routines are handled } else { $process_all_functions = $FALSE; } my $txt; $txt = "value of time_percentage_multiplier = " . $time_percentage_multiplier; gp_message ("debugM", $subr_name, $txt); $txt = "value of process_all_functions = " . ($process_all_functions ? "TRUE" : "FALSE"); gp_message ("debugM", $subr_name, $txt); } #------------------------------------------------------------------------------ # If imetrics has been set, split the list into the individual metrics that # need to be excluded. The associated hash called $ignore_metrics has the # to be excluded metrics as an index. The value of $TRUE assigned does not # really matter. #------------------------------------------------------------------------------ my @candidate_ignored_metrics; if ($g_user_settings{"ignore_metrics"}{"defined"}) { @candidate_ignored_metrics = split (":", $g_user_settings{"ignore_metrics"}{"current_value"}); } for my $metric (@candidate_ignored_metrics) { # TBD: bug? $ignored_metrics{$metric} = $FALSE; $ignored_metrics{$metric} = $TRUE; } for my $metric (keys %ignored_metrics) { my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; gp_message ("debugM", $subr_name, $txt); } #------------------------------------------------------------------------------ # Check if the experiment directories exist. #------------------------------------------------------------------------------ for my $i (0 .. $#exp_dir_list) { if (-d $exp_dir_list[$i]) { my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); $exp_dir_list[$i] = $abs_path_dir; my $txt = "directory $exp_dir_list[$i] exists"; gp_message ("debugM", $subr_name, $txt); } else { my $msg = "directory $exp_dir_list[$i] does not exist"; push (@g_user_input_errors, $msg); $option_errors++; } } return ($option_errors, \%ignored_metrics, $outputdir, $time_percentage_multiplier, $process_all_functions, \@exp_dir_list); } #-- End of subroutine process_user_options #------------------------------------------------------------------------------ # This is a hopefully temporary routine to disable/ignore selected user # settings. As the functionality expands, this list will get shorter. #------------------------------------------------------------------------------ sub reset_selected_settings { my $subr_name = get_my_name (); $g_locale_settings{"decimal_separator"} = "\\."; $g_locale_settings{"convert_to_dot"} = $FALSE; $g_user_settings{func_limit}{current_value} = 1000000; gp_message ("debug", $subr_name, "reset selected settings"); return (0); } #-- End of subroutine reset_selected_settings #------------------------------------------------------------------------------ # There may be various different visibility characters in a metric definition. # For example: e+%CPI. # # Internally we use a normalized definition that only uses the dot (e.g. # e.CPI) as an index into the description structure. # # Here we reduce the incoming metric definition to the normalized form, look # up the text, and return a pointer to it. #------------------------------------------------------------------------------ sub retrieve_metric_description { my $subr_name = get_my_name (); my ($metric_name_ref, $metric_description_ref) = @_; my $metric_name = ${ $metric_name_ref }; my %metric_description = %{ $metric_description_ref }; my $description; my $normalized_metric; $metric_name =~ /([ei])([\.\+%]+)(.*)/; if (defined ($1) and defined ($3)) { $normalized_metric = $1 . "." . $3; } else { my $msg = "metric $metric_name has an unknown format"; gp_message ("assertion", $subr_name, $msg); } if (defined ($metric_description{$normalized_metric})) { $description = $metric_description{$normalized_metric}; } else { my $msg = "description for normalized metric $normalized_metric not found"; gp_message ("assertion", $subr_name, $msg); } return (\$description); } #-- End of subroutine retrieve_metric_description #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ sub rnumerically { my ($f1,$f2); if ($a =~ /^([^\d]*)(\d+)/) { $f1 = int ($2); if ($b=~ /^([^\d]*)(\d+)/) { $f2 = int ($2); $f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1); } } else { return ($b <=> $a); } } #-- End of subroutine rnumerically #------------------------------------------------------------------------------ # TBD: Remove - not used any longer. # Set the architecture and associated regular expressions. #------------------------------------------------------------------------------ sub set_arch_and_regexes { my $subr_name = get_my_name (); my ($arch_uname) = @_; my $architecture_supported; gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); if ($arch_uname eq "x86_64") { #x86/x64 hardware uses jump $architecture_supported = $TRUE; # $arch='x64'; # $regex=':\s+(j).*0x[0-9a-f]+'; # $subexp='(\[\s*)(0x[0-9a-f]+)'; # $linksubexp='(\[\s*)(0x[0-9a-f]+)'; gp_message ("debug", $subr_name, "detected $arch_uname hardware"); $architecture_supported = $TRUE; $g_arch_specific_settings{"arch_supported"} = $TRUE; $g_arch_specific_settings{"arch"} = 'x64'; $g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+'; $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)'; $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)'; } #------------------------------------------------------------------------------- # TBD: Remove the elsif block #------------------------------------------------------------------------------- elsif ($arch_uname=~m/sparc/s) { #sparc hardware uses branch $architecture_supported = $FALSE; # $arch='sparc'; # $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; # $subexp='(\s*)(0x[0-9a-f]+)\s*$'; # $linksubexp='(\s*)(0x[0-9a-f]+\s*$)'; # gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported"); $architecture_supported = $FALSE; $g_arch_specific_settings{arch_supported} = $FALSE; $g_arch_specific_settings{arch} = 'sparc'; $g_arch_specific_settings{regex} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; $g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$'; $g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)'; } else { $architecture_supported = $FALSE; gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality"); } return ($architecture_supported); } #-- End of subroutine set_arch_and_regexes #------------------------------------------------------------------------------ # Set the background color of the input string. # # For supported colors, see: # https://www.w3schools.com/colors/colors_names.asp #------------------------------------------------------------------------------ sub set_background_color_string { my $subr_name = get_my_name (); my ($input_string, $color) = @_; my $background_color_string; my $msg; $msg = "color = $color input_string = $input_string"; gp_message ("debugXL", $subr_name, $msg); $background_color_string = "<span style='background-color: " . $color . "'>" . $input_string . "</span>"; $msg = "color = $color background_color_string = " . $background_color_string; gp_message ("debugXL", $subr_name, $msg); return ($background_color_string); } #-- End of subroutine set_background_color_string #------------------------------------------------------------------------------ # Set the g_debug_size structure for a given value for "size". Also set the # value in $g_user_settings{"debug"}{"current_value"} #------------------------------------------------------------------------------ sub set_debug_size { my $subr_name = get_my_name (); my ($debug_value_ref) = @_; my $debug_value = lc (${ $debug_value_ref }); #------------------------------------------------------------------------------ # Regardless of the value, the debug settings are defined here. #------------------------------------------------------------------------------ $g_user_settings{"debug"}{"defined"} = $TRUE; #------------------------------------------------------------------------------ # By default, set the value to "on", but correct below if needed. #------------------------------------------------------------------------------ $g_user_settings{"debug"}{"current_value"} = "on"; if (($debug_value eq "on") or ($debug_value eq "s")) { $g_debug_size{"on"} = $TRUE; $g_debug_size{"s"} = $TRUE; } elsif ($debug_value eq "m") { $g_debug_size{"on"} = $TRUE; $g_debug_size{"s"} = $TRUE; $g_debug_size{"m"} = $TRUE; } elsif ($debug_value eq "l") { $g_debug_size{"on"} = $TRUE; $g_debug_size{"s"} = $TRUE; $g_debug_size{"m"} = $TRUE; $g_debug_size{"l"} = $TRUE; } elsif ($debug_value eq "xl") { $g_debug_size{"on"} = $TRUE; $g_debug_size{"s"} = $TRUE; $g_debug_size{"m"} = $TRUE; $g_debug_size{"l"} = $TRUE; $g_debug_size{"xl"} = $TRUE; } else #------------------------------------------------------------------------------ # Any other value is considered to disable debugging. #------------------------------------------------------------------------------ { $g_user_settings{"debug"}{"current_value"} = "off"; $g_debug_size{"on"} = $FALSE; $g_debug_size{"s"} = $FALSE; $g_debug_size{"m"} = $FALSE; $g_debug_size{"l"} = $FALSE; $g_debug_size{"xl"} = $FALSE; } #------------------------------------------------------------------------------ # Activate in case of an emergency :-) #------------------------------------------------------------------------------ ## if ($g_debug_size{$debug_value}) ## { ## for my $i (keys %g_debug_size) ## { ## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; ## } ## } return (0); } #-- End of subroutine set_debug_size #------------------------------------------------------------------------------ # This subroutine defines the default metrics. #------------------------------------------------------------------------------ sub set_default_metrics { my $subr_name = get_my_name (); my ($outfile1, $ignored_metrics_ref) = @_; my %ignored_metrics = %{ $ignored_metrics_ref }; my %metric_description = (); my %metric_found = (); my $detail_metrics; my $detail_metrics_system; my $call_metrics = ""; my $summary_metrics = ""; open (METRICS, "<", $outfile1) or die ("Unable to open metrics file $outfile1 for reading - '$!'"); gp_message ("debug", $subr_name, "opened $outfile1 for reading"); while (<METRICS>) { my $metric_line = $_; chomp ($metric_line); gp_message ("debug", $subr_name,"the value of metric_line = $metric_line"); #------------------------------------------------------------------------------ # Decode the metric part of the input line. If a valid line, return the # metric components. Otherwise return "skipped" in the metric_spec field. #------------------------------------------------------------------------------ my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line); gp_message ("debug", $subr_name, "metric_spec = $metric_spec"); gp_message ("debug", $subr_name, "metric_flavor = $metric_flavor"); if ($metric_spec eq "skipped") #------------------------------------------------------------------------------ # Not a valid input line. #------------------------------------------------------------------------------ { gp_message ("debug", $subr_name, "skipped line: $metric_line"); } else { #------------------------------------------------------------------------------ # A valid metric field has been found. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "metric_name = $metric_name"); gp_message ("debug", $subr_name, "metric_description = $metric_description"); # if (exists ($IMETRICS{$m})){ if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name})) { gp_message ("debug", $subr_name, "user requested to ignore metric $metric_name"); next; } #------------------------------------------------------------------------------ # Only the exclusive metric is selected. #------------------------------------------------------------------------------ if ($metric_flavor eq "e") { $metric_found{$metric_spec} = $TRUE; $metric_description{$metric_spec} = $metric_description; # TBD: remove the -AO: gp_message ("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}"); $summary_metrics .= $metric_spec.":"; $call_metrics .= "a.".$metric_name.":"; } } } close (METRICS); chop ($call_metrics); chop ($summary_metrics); $detail_metrics = $summary_metrics; $detail_metrics_system = $summary_metrics; return (\%metric_description, \%metric_found, $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); } #-- End of subroutine set_default_metrics #------------------------------------------------------------------------------ # Set various system specific variables. These depend upon both the processor # architecture and OS. The values are stored in global structure # g_arch_specific_settings. #------------------------------------------------------------------------------ sub set_system_specific_variables { my $subr_name = get_my_name (); my ($arch_uname, $arch_uname_s) = @_; my $elf_arch; my $read_elf_cmd; my $elf_support; my $architecture_supported; my $arch; my $regex; my $subexp; my $linksubexp; if ($arch_uname eq "x86_64") { #------------------------------------------------------------------------------ # x86/x64 hardware uses jump #------------------------------------------------------------------------------ $architecture_supported = $TRUE; $arch = 'x64'; $regex =':\s+(j).*0x[0-9a-f]+'; $subexp ='(\[\s*)(0x[0-9a-f]+)'; $linksubexp ='(\[\s*)(0x[0-9a-f]+)'; # gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch"); $g_arch_specific_settings{"arch_supported"} = $TRUE; $g_arch_specific_settings{"arch"} = 'x64'; #------------------------------------------------------------------------------ # Define the regular expressions to parse branch instructions. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # TBD: Need much more than these #------------------------------------------------------------------------------ $g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)'; $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)'; } else { $architecture_supported = $FALSE; $g_arch_specific_settings{"arch_supported"} = $FALSE; } #------------------------------------------------------------------------------ # TBD Ruud: need to handle this better #------------------------------------------------------------------------------ if ($arch_uname_s eq "Linux") { $elf_arch = $arch_uname_s; $read_elf_cmd = $g_mapped_cmds{"readelf"}; if ($read_elf_cmd eq "road_to_nowhere") { $elf_support = $FALSE; } else { $elf_support = $TRUE; } gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch"); } else { gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported"); } return ($architecture_supported, $elf_arch, $elf_support); } #-- End of subroutine set_system_specific_variables #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub set_title { my $subr_name = get_my_name (); my ($function_info_ref, $func, $from_where) = @_ ; my $msg; my @function_info = @{$function_info_ref}; my $filename = $func ; my $base; my $first_line; my $src_file; my $RI; my $the_title; my $routine = "?"; my $DIS; my $SRC; chomp ($filename); $base = get_basename ($filename); gp_message ("debug", $subr_name, "from_where = $from_where"); gp_message ("debug", $subr_name, "base = $base filename = $filename"); if ($from_where eq "process source") { if ($base =~ /^file\.(\d+)\.src\.txt$/) { if (defined ($1)) { $RI = $1; } else { $msg = "unexpected error encountered parsing $filename"; gp_message ("assertion", $subr_name, $msg); } } $the_title = "Source"; } elsif ($from_where eq "disassembly") { if ($base =~ /^file\.(\d+)\.dis$/) { if (defined ($1)) { $RI = $1; } else { $msg = "unexpected error encountered parsing $filename"; gp_message ("assertion", $subr_name, $msg); } } $the_title = "Disassembly"; } else { $msg = "called from unknown routine - $from_where"; gp_message ("assertion", $subr_name, $msg); } if (defined ($function_info[$RI]{"routine"})) { $routine = $function_info[$RI]{"routine"}; } if ($from_where eq "process source") { my $is_empty = is_file_empty ($filename); if ($is_empty) { $src_file = ""; } else { open ($SRC, "<", $filename) or die ("$subr_name - unable to open source file $filename for reading:'$!'"); gp_message ("debug", $subr_name, "opened file $filename for reading"); $first_line = <$SRC>; chomp ($first_line); close ($SRC); gp_message ("debug", $subr_name, "first_line = $first_line"); if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) { $src_file = $1 } else { $src_file = ""; } } } elsif ($from_where eq "disassembly") { open ($DIS, "<", $filename) or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); gp_message ("debug", $subr_name, "opened file $filename for reading"); $first_line = <$DIS>; close ($DIS); if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) { $src_file = "$1" } else { $src_file = ""; } } if (length ($routine)) { $the_title .= " $routine"; } if (length ($src_file)) { if ($src_file ne "(unknown)") { $the_title .= " ($src_file)"; } else { $the_title .= " $src_file"; } } return ($the_title); } #-- End of subroutine set_title #------------------------------------------------------------------------------ # Handles where the output should go. If needed, a directory is # created # where the results will go. #------------------------------------------------------------------------------ sub set_up_output_directory { my $subr_name = get_my_name (); my $error_code; my $message; my $mkdir_output_msg; my $option_errors; my $outputdir = "does_not_exist_yet"; my $rm_output_msg; my $target_cmd; my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; $option_errors = 0; if ((not $define_new_output_dir) and (not $overwrite_output_dir)) #------------------------------------------------------------------------------ # If neither -o or -O are set, find the next number to be used in the name for # the default output directory. #------------------------------------------------------------------------------ { my $dir_id = 1; while (-d "display.".$dir_id.".html") { $dir_id++; } $outputdir = "display.".$dir_id.".html"; } elsif ($define_new_output_dir) #------------------------------------------------------------------------------ # The output directory is defined with the -o option. #------------------------------------------------------------------------------ { $outputdir = $g_user_settings{"output"}{"current_value"}; } elsif ($overwrite_output_dir) #------------------------------------------------------------------------------ # The output directory is defined with the -O option. #------------------------------------------------------------------------------ { $outputdir = $g_user_settings{"overwrite"}{"current_value"}; } #------------------------------------------------------------------------------ # The name of the output directory is known and we can proceed. #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "the target output directory is $outputdir"); if (-d $outputdir) { #------------------------------------------------------------------------------ # The -o option is used, but the directory already exists. #------------------------------------------------------------------------------ if ($define_new_output_dir) { $message = "directory $outputdir already exists"; $message .= " (use the -O option to overwrite an existing directory)"; push (@g_user_input_errors, $message); $option_errors++; return ($option_errors, $outputdir); } elsif ($overwrite_output_dir) #------------------------------------------------------------------------------ # It is a bit risky to remove this directory and so we proceed with caution. # What if the user decides to call it "*" e.g. "-O \*" for example? While this # should have been caught when processing the options, we still like to # be very cautious here before executing /bin/rm -rf. #------------------------------------------------------------------------------ { if ($outputdir eq "*") { $message = "it is not allowed to use * as a value for the -O option"; push (@g_user_input_errors, $message); $option_errors++; return ($option_errors, $outputdir); } else { #------------------------------------------------------------------------------ # The output directory exists, but it is okay to overwrite it. It is # removed here and created again below. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir; ($error_code, $rm_output_msg) = execute_system_cmd ($target_cmd); if ($error_code != 0) { gp_message ("error", $subr_name, $rm_output_msg); gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); } else { gp_message ("debug", $subr_name, "directory $outputdir has been removed"); } } } } #-- End of if-check for $outputdir #------------------------------------------------------------------------------- # When we get here, the fatal scenarios have been cleared and the name for # $outputdir is known. Time to create it. Note that recursive creation is # supported and umask controls the access permissions. #------------------------------------------------------------------------------- $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir; ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd); if ($error_code != 0) { my $msg = "a fatal problem occurred when creating directory $outputdir"; gp_message ("abort", $subr_name, $msg); } else { gp_message ("debug", $subr_name, "created output directory $outputdir"); } return ($option_errors, $outputdir); } #-- End of subroutine set_up_output_directory #------------------------------------------------------------------------------ # Routine to generate webfriendly names #------------------------------------------------------------------------------ sub tag_name { my $subr_name = get_my_name (); my ($target_name) = @_; #------------------------------------------------------------------------------ # Keeps track how many names have been tagged already. #------------------------------------------------------------------------------ state $S_total_tagged_names = 0; my $unique_name; gp_message ("debug", $subr_name, "target_name on entry = $target_name"); #------------------------------------------------------------------------------ # Undo conversion of < in to < #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # TBD: Legacy - What is going on here and is this really needed?! # We need to replace the "<" symbol in the code by "<". #------------------------------------------------------------------------------ $target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g; #------------------------------------------------------------------------------ # Remove inlining info #------------------------------------------------------------------------------ $target_name =~ s/, instructions from source file.*//; if (defined $g_tagged_names{$target_name}) { gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}"); gp_message ("debug", $subr_name, "target_name on return = $target_name"); return ($g_tagged_names{$target_name}); } else { $unique_name = "ftag".$S_total_tagged_names; $S_total_tagged_names++; $g_tagged_names{$target_name} = $unique_name; gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}"); gp_message ("debug", $subr_name, "target_name on return = $target_name"); return ($unique_name); } } #-- End of subroutine tag_name #------------------------------------------------------------------------------ # Generate a string to terminate the HTML document. #------------------------------------------------------------------------------ sub terminate_html_document { my $subr_name = get_my_name (); my $html_line; $html_line = "</body>\n"; $html_line .= "</html>"; return (\$html_line); } #-- End of subroutine terminate_html_document #------------------------------------------------------------------------------- # Perform some basic checks to ensure the input data is consistent. This part # could be refined and expanded over time. For example by using a checksum # mechanism to verify the consistency of the executables. #------------------------------------------------------------------------------- sub verify_consistency_experiments { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my $executable_name; my $full_path_executable_name; my $ref_executable_name; my $first_exp_dir = $TRUE; my $count_differences = 0; #------------------------------------------------------------------------------- # Enforce that the full path names to the executable are the same. This could # be overkill and a checksum approach would be more flexible. #------------------------------------------------------------------------------- for my $full_exp_dir (@exp_dir_list) { my $exp_dir = get_basename ($full_exp_dir); gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); if ($first_exp_dir) { $first_exp_dir = $FALSE; $ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name"); next; } $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name"); if ($full_path_executable_name ne $ref_executable_name) { $count_differences++; gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name"); } } $executable_name = get_basename ($ref_executable_name); return ($count_differences, $executable_name); } #-- End of subroutine verify_consistency_experiments #------------------------------------------------------------------------------ # Check if the input item is valid for the data type specified. Validity is # verified in the context of gprofng. The definition for the metrics is a # good example of that. #------------------------------------------------------------------------------ sub verify_if_input_is_valid { my $subr_name = get_my_name (); my ($input_item, $data_type) = @_; my $return_value = $FALSE; #------------------------------------------------------------------------------ # These value are allowed to be case insensitive, so we convert to lower # case first. #------------------------------------------------------------------------------ if (($data_type eq "onoff") or ($data_type eq "size")) { $input_item = lc ($input_item); } if ($data_type eq "metrics") #------------------------------------------------------------------------------ # A gprofng metric definition. Either consists of "default" only, or starts # with e or i, followed by one or more from the set {.,%,!,+} and a keyword. # This pattern may be repeated with a ":" as the separator. #------------------------------------------------------------------------------ { my @metric_list = split (":", $input_item); #------------------------------------------------------------------------------ # Check if the pattern is valid. If not, bail out and return $FALSE. #------------------------------------------------------------------------------ for my $metric (@metric_list) { if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/) { $return_value = $TRUE; } else { $return_value = $FALSE; last; } } } elsif ($data_type eq "metric_names") #------------------------------------------------------------------------------ # A gprofng metric definition but without the flavour and visibility . Either # the name consists of "default" only, or a keyword with lowercase letters # only. This pattern may be repeated with a ":" as the separator. #------------------------------------------------------------------------------ { my @metric_list = split (":", $input_item); #------------------------------------------------------------------------------ # Check if the pattern is valid. If not, bail out and return $FALSE. #------------------------------------------------------------------------------ for my $metric (@metric_list) { if ($metric =~ /^default$|^[a-z]*$/) { $return_value = $TRUE; } else { $return_value = $FALSE; last; } } } elsif ($data_type eq "path") #------------------------------------------------------------------------------ # This can be almost anything, including "/" and "." #------------------------------------------------------------------------------ { if ($input_item =~ /^[\w\/\.]*$/) { $return_value = $TRUE; } } elsif ($data_type eq "boolean") { #------------------------------------------------------------------------------ # This is TRUE (=1) or FALSE (0). #------------------------------------------------------------------------------ if ($input_item =~ /^[01]$/) { $return_value = $TRUE; } } elsif ($data_type eq "onoff") #------------------------------------------------------------------------------ # This is either "on" OR "off". #------------------------------------------------------------------------------ { if ($input_item =~ /^on$|^off$/) { $return_value = $TRUE; } } elsif ($data_type eq "size") #------------------------------------------------------------------------------ # Supported values are "on", "off", "s", "m", "l", OR "xl". #------------------------------------------------------------------------------ { if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/) { $return_value = $TRUE; } } elsif ($data_type eq "pinteger") #------------------------------------------------------------------------------ # This is a positive integer. #------------------------------------------------------------------------------ { if ($input_item =~ /^\d*$/) { $return_value = $TRUE; } } elsif ($data_type eq "integer") #------------------------------------------------------------------------------ # This is a positive or negative integer. #------------------------------------------------------------------------------ { if ($input_item =~ /^\-?\d*$/) { $return_value = $TRUE; } } elsif ($data_type eq "pfloat") #------------------------------------------------------------------------------ # This is a positive floating point number, but we accept a positive integer # number as well. # # TBD: Note that we use the "." here. Maybe should support a "," too. #------------------------------------------------------------------------------ { if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/)) { $return_value = $TRUE; } } elsif ($data_type eq "float") #------------------------------------------------------------------------------ # This is a positive or negative floating point number, but we accept an # integer number as well. # # TBD: Note that we use the "." here. Maybe should support a "," too. #------------------------------------------------------------------------------ { if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/)) { $return_value = $TRUE; } } else { my $msg = "the $data_type data type for input $input_item is not supported"; gp_message ("assertion", $subr_name, $msg); } return ($return_value); } #-- End of subroutine verify_if_input_is_valid