#!/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; # Disable before release # use Perl::Critic; use bignum; use List::Util qw (max); use Cwd qw (abs_path cwd); use File::Basename; use File::stat; use feature qw (state); use POSIX; use Getopt::Long qw (Configure); #------------------------------------------------------------------------------ # Check as early as possible if the version of Perl used is supported. #------------------------------------------------------------------------------ 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; #------------------------------------------------------------------------------ # The total number of functions to be processed. #------------------------------------------------------------------------------ my $g_total_function_count = 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]'; my $g_rm_surrounding_spaces_regex = '^\s+|\s+$'; #------------------------------------------------------------------------------ # For consistency, use a global variable. #------------------------------------------------------------------------------ my $g_html_new_line = "<br>"; #------------------------------------------------------------------------------ # 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*'; my $g_first_metric; my $binutils_version; my $driver_cmd; my $tool_name; my $version_info; my %g_mapped_cmds = (); #------------------------------------------------------------------------------ # Variables dealing with warnings and errors. Since a message may span # multiple lines (for readability reasons), the number of entries in the # array may not reflect the total number of messages. This is why we use # separate variables for the counts. #------------------------------------------------------------------------------ my @g_error_msgs = (); my @g_warning_msgs = (); my $g_total_error_count = 0; #------------------------------------------------------------------------------ # This count is used in the html_create_warnings_page HTML page to show how # many warning messages there are. Warnings are printed through gp_message(), # but since one warning may span multiple lines, we update a separate counter # that contains the total number of warning messages issued so far. #------------------------------------------------------------------------------ my $g_total_warning_count = 0; my $g_options_printed = $FALSE; my $g_abort_msg = "cannot recover from the error(s)"; #------------------------------------------------------------------------------ # Contains the names that have already been tagged. This is a global # 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_html_credits_line; my $g_warn_keyword = "[Warning]"; my $g_error_keyword = "[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.42"; $version_info = $tool_name . " GNU binutils version " . $binutils_version; #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Define several key data structures. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # This table has the settings of the variables the user may set. #------------------------------------------------------------------------------ my %g_user_settings = ( verbose => { option => "--verbose", no_of_arguments => 1, data_type => "onoff", current_value => "off", defined => $FALSE}, debug => { option => "--debug", no_of_arguments => 1, data_type => "size", current_value => "off", defined => $FALSE}, warnings => { option => "--warnings", no_of_arguments => 1, data_type => "onoff" , current_value => "off", defined => $FALSE}, nowarnings => { option => "--nowarnings", no_of_arguments => 1, data_type => "onoff", current_value => "off", defined => $FALSE}, quiet => { option => "--quiet", no_of_arguments => 1, data_type => "onoff", current_value => "off", defined => $FALSE}, output => { option => "-o", no_of_arguments => 1, data_type => "path", current_value => undef, defined => $FALSE}, overwrite => { option => "-O", no_of_arguments => 1, data_type => "path", current_value => undef, defined => $FALSE}, calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff", current_value => "off", defined => $FALSE}, func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500, defined => $FALSE}, highlight_percentage => { option => "--highlight-percentage", no_of_arguments => 1, data_type => "pfloat", current_value => 90.0, defined => $FALSE}, hp => { option => "-hp", no_of_arguments => 1, data_type => "pfloat", current_value => 90.0, defined => $FALSE}, threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat", current_value => 100.0, defined => $FALSE}, default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff", current_value => "off", defined => $FALSE}, ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE}, ); #------------------------------------------------------------------------------ # Convenience. These map the on/off value to $TRUE/$FALSE to make the code # easier to read. For example: "if ($g_verbose)" as opposed to the following: # "if ($verbose_setting eq "on"). #------------------------------------------------------------------------------ my $g_verbose = $FALSE; my $g_debug = $FALSE; my $g_warnings = $TRUE; my $g_quiet = $FALSE; #------------------------------------------------------------------------------ # Since ARGV is modified when parsing the options, a clean copy is used to # print the original ARGV values in case of a warning, or error. #------------------------------------------------------------------------------ my @CopyOfARGV = (); my %g_debug_size = ( "on" => $FALSE, "s" => $FALSE, "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", ); #------------------------------------------------------------------------------ # Introducing main() 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 (); @CopyOfARGV = @ARGV; #------------------------------------------------------------------------------ # The name of the configuration file. #------------------------------------------------------------------------------ my $rc_file_name = ".gp-display-html.rc"; #------------------------------------------------------------------------------ # OS commands executed and search paths. # # TBD: check if elfdump should be here too (most likely not though) #------------------------------------------------------------------------------ my @selected_os_cmds = qw (rm cat hostname locale which printenv 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 = (); 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 $found_exp_dir; my $ignore_value; my $msg; my $number_of_metrics; my $va_executable_in_hex; my $failed_command_mappings; 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 $html_test; my @experiment_data; my $exp_info_file; my $exp_info_ref; my @exp_info; 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; #------------------------------------------------------------------------------ # 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 warnings and # errors. The warnings, if any, will be printed once the command line has # been parsed and verified. Execution continues. # # Any error(s) accumulated in this phase will be printed after the command # line has been parsed and verified. Execution is then terminated. # # In the remainder, any error encountered will immediately terminate the # execution because we can't guarantee the remaining code will work up to # some point. #------------------------------------------------------------------------------ my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options (); $found_exp_dir = ${ $found_exp_dir_ref }; if ($found_exp_dir) { @exp_dir_list = @{ $exp_dir_list_ref }; } else { $msg = "the list with experiments is either missing, or incorrect"; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # The final settings for verbose, debug, warnings and quiet are known and the # gp_message() subroutine is aware of these. #------------------------------------------------------------------------------ $msg = "parsing of the user options completed"; gp_message ("verbose", $subr_name, $msg); #------------------------------------------------------------------------------ # The user options have been taken in. Check for validity and consistency. #------------------------------------------------------------------------------ $msg = "process user options"; gp_message ("verbose", $subr_name, $msg); ($ignored_metrics_ref, $outputdir, $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) = process_user_options (\@exp_dir_list); @exp_dir_list = @{ $exp_dir_list_ref }; %ignored_metrics = %{$ignored_metrics_ref}; #------------------------------------------------------------------------------ # 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). #------------------------------------------------------------------------------ gp_message ("debug", $subr_name, "verify the OS commands"); $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds); if ($failed_command_mappings == 0) { $msg = "successfully verified the OS commands"; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Time to check if any warnings and/or errors have been generated. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # We have completed all the upfront checks. Print any warnings and errors. # If there are already any errors, execution is terminated. As execution # continues, errors may occur and they are typically fatal. #------------------------------------------------------------------------------ if ($g_debug) { $msg = "internal settings after option processing"; $ignore_value = print_table_user_settings ("diag", $msg); } #------------------------------------------------------------------------------ # Terminate execution in case fatal errors have occurred. #------------------------------------------------------------------------------ if ( $g_total_error_count > 0) { my $msg = "the current values for the user controllable settings"; print_user_settings ("debug", $msg); gp_message ("abort", $subr_name, $g_abort_msg); } else { my $msg = "after parsing the user options, the final values are"; print_user_settings ("debug", $msg); } #------------------------------------------------------------------------------ # If no option is given for the output directory, pick a default. Otherwise, # if the output directory exists, wipe it clean in case the -O option is used. # If not, raise an error because the -o option does not overwrite an existing # directory. # Also in case of other errors, the execution is terminated. #------------------------------------------------------------------------------ $outputdir = set_up_output_directory (); $abs_path_outputdir = Cwd::cwd () . "/" . $outputdir; $msg = "the output directory is $outputdir"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Get the home directory and the locations for the configuration file on the # current system. #------------------------------------------------------------------------------ ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); @rc_file_paths = @{ $rc_file_paths_ref }; $msg = "the home directory is $home_dir"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # TBD: de-activated until this feature has been fully implemented. #------------------------------------------------------------------------------ ## $msg = "the search path for the rc file is @rc_file_paths"; ## gp_message ("debug", $subr_name, $msg); ## $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); #------------------------------------------------------------------------------ # Get the ball rolling. Parse and interpret the configuration file (if any) # and the command line options. # # Note that the verbose, debug, and quiet options can be set in this file. # It is a deliberate choice to ignore these for now. The assumption is that # the user will not be happy if we ignore the command line settings for a # while. #------------------------------------------------------------------------------ $msg = "processing of the rc file has been disabled for now"; gp_message ("debugXL", $subr_name, $msg); # Temporarily disabled # print_table_user_settings ("debugXL", "before function process_rc_file"); # $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); # if ($rc_file_errors != 0) # { # $message = "fatal errors in file $rc_file_name encountered"; # gp_message ("debugXL", $subr_name, $message); # } # print_table_user_settings ("debugXL", "after function process_rc_file"); #------------------------------------------------------------------------------ # Print a list with the experiment directory names #------------------------------------------------------------------------------ $pretty_dir_list = build_pretty_dir_list (\@exp_dir_list); my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is"; $msg = "the experiment " . $plural . ":"; gp_message ("verbose", $subr_name, $msg); 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; } #------------------------------------------------------------------------------ # TBD: # This subroutine may be overkill. See what is really needed here and remove # everything else. # # Upon return, one directory has been selected to be used in the remainder. # This is not always the correct thing to do, but is the same as the original # code. In due time this should be addressed though. #------------------------------------------------------------------------------ ($archive_dir_not_empty, $selected_archive, $elf_rats_ref) = check_validity_exp_dirs (\@exp_dir_list); %elf_rats = %{$elf_rats_ref}; $msg = "the experiment directories have been verified and are valid"; gp_message ("verbose", $subr_name, $msg); #------------------------------------------------------------------------------ # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. This includes setting the base virtual address. #------------------------------------------------------------------------------ $ignore_value = determine_base_virtual_address ($exp_dir_list_ref); #------------------------------------------------------------------------------ # Check whether the experiment directories are consistent. #------------------------------------------------------------------------------ ($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref); if ($consistency_errors == 0) { $msg = "the experiment directories are consistent"; gp_message ("verbose", $subr_name, $msg); } else { $msg = "the number of consistency errors detected: $consistency_errors"; gp_message ("abort", $subr_name, $msg); } #------------------------------------------------------------------------------ # The directories are consistent. We can now set the base virtual address of # the executable. #------------------------------------------------------------------------------ $base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; $msg = "executable_name = " . $executable_name; gp_message ("debug", $subr_name, $msg); $msg = "selected_archive = " . $selected_archive; gp_message ("debug", $subr_name, $msg); $msg = "base_va_executable = " . $base_va_executable; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # The $GP_DISPLAY_TEXT tool is critical and has to be available in order to # proceed. # This subroutine only returns a value if the tool can be found. #------------------------------------------------------------------------------ $g_path_to_tools = ${ check_availability_tool (\$location_gp_command)}; $GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT; $msg = "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Check if $GP_DISPLAY_TEXT is executable for user, group, and other. # 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)) { $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and"; $msg .= " other"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Find out what the decimal separator is, as set by the user. #------------------------------------------------------------------------------ ($return_code, $decimal_separator, $convert_to_dot) = determine_decimal_separator (); if ($return_code == 0) { $msg = "decimal separator is $decimal_separator"; $msg .= " (conversion to dot is "; $msg .= ($convert_to_dot == $TRUE ? "enabled" : "disabled") . ")"; gp_message ("debugXL", $subr_name, $msg); } else { $msg = "the decimal separator cannot be determined -"; $msg .= " set to $decimal_separator"; gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Collect and store the system information. #------------------------------------------------------------------------------ $msg = "collect system information and adapt settings"; gp_message ("verbose", $subr_name, $msg); $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); $msg = "architecture_supported = $architecture_supported"; gp_message ("debug", $subr_name, $msg); $msg = "elf_arch = $elf_arch"; gp_message ("debug", $subr_name, $msg); $msg = "elf_support = ".($elf_arch ? "TRUE" : "FALSE"); gp_message ("debug", $subr_name, $msg); for my $feature (sort keys %g_arch_specific_settings) { $msg = "g_arch_specific_settings{$feature} = "; $msg .= $g_arch_specific_settings{$feature}; gp_message ("debug", $subr_name, $msg); } $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 (); $msg = "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Temporarily reset selected settings since these are not yet implemented. #------------------------------------------------------------------------------ $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; $msg = "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"; gp_message ("debugXL", $subr_name, $msg); $msg = "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"; gp_message ("debugXL", $subr_name, $msg); $msg = "after call to check_loadobjects_are_elf forced"; $msg .= " elf_loadobjects_found = $elf_loadobjects_found"; gp_message ("debugXL", $subr_name, $msg); $g_html_credits_line = ${ create_html_credits () }; $msg = "g_html_credits_line = $g_html_credits_line"; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Add a "/" to simplify the construction of path names in the remainder. # # 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. #------------------------------------------------------------------------------ $msg = "gather the metrics data from the experiments"; gp_message ("verbose", $subr_name, $msg); $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file); if ($return_code != 0) { gp_message ("abort", $subr_name, "execution terminated"); } #------------------------------------------------------------------------------ # TBD: Test this code #------------------------------------------------------------------------------ $msg = "unable to open metric value data file $outfile1 for reading:"; open (METRICS, "<", $outfile1) or die ($subr_name . " - " . $msg . " " . $!); $msg = "opened file $outfile1 for reading"; gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); chomp (@metrics_data = <METRICS>); close (METRICS); for my $i (keys @metrics_data) { $msg = "metrics_data[$i] = " . $metrics_data[$i]; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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; $msg = "after the call to process_metrics_data"; gp_message ("debugXL", $subr_name, $msg); for my $metric (sort keys %metric_value) { $msg = "metric_value{$metric} = " . $metric_value{$metric}; gp_message ("debugXL", $subr_name, $msg); } for my $metric (sort keys %metric_description) { $msg = "metric_description{$metric} ="; $msg .= " " . $metric_description{$metric}; gp_message ("debugXL", $subr_name, $msg); } gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics"); gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics"); gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics"); } else { #------------------------------------------------------------------------------ # A default set of metrics will be used. # # TBD: These should be OS dependent. #------------------------------------------------------------------------------ $msg = "select the set of default metrics"; gp_message ("verbose", $subr_name, $msg); ($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; $msg = "after the call to set_default_metrics"; gp_message ("debug", $subr_name, $msg); } $number_of_metrics = split (":", $summary_metrics); $msg = "summary_metrics = " . $summary_metrics; gp_message ("debugXL", $subr_name, $msg); $msg = "detail_metrics = " . $detail_metrics; gp_message ("debugXL", $subr_name, $msg); $msg = "detail_metrics_system = " . $detail_metrics_system; gp_message ("debugXL", $subr_name, $msg); $msg = "call_metrics = " . $call_metrics; gp_message ("debugXL", $subr_name, $msg); $msg = "number_of_metrics = " . $number_of_metrics; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # TBD Find a way to better handle this situation: #------------------------------------------------------------------------------ for my $im (keys %metric_found) { $msg = "metric_found{$im} = " . $metric_found{$im}; gp_message ("debugXL", $subr_name, $msg); } for my $im (keys %ignored_metrics) { if (not exists ($metric_found{$im})) { $msg = "user requested ignored metric (-im) $im does not exist in"; $msg .= " collected metrics"; gp_message ("debugXL", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Get the information on the experiments. #------------------------------------------------------------------------------ $msg = "generate the experiment information"; gp_message ("verbose", $subr_name, $msg); my $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); @experiment_data = @{ $experiment_data_ref }; for my $i (sort keys @experiment_data) { my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . $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. #------------------------------------------------------------------------------ $msg = "generate the list with functions executed"; gp_message ("verbose", $subr_name, $msg); my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); @sort_fields = @{$sort_fields_ref}; #------------------------------------------------------------------------------ # Parse the output from the fsummary command and store the relevant data for # all the functions listed there. #------------------------------------------------------------------------------ $msg = "analyze and store the relevant function information"; gp_message ("verbose", $subr_name, $msg); ($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 }; $msg = "found " . $g_total_function_count . " functions to process"; gp_message ("verbose", $subr_name, $msg); for my $keys (0 .. $#function_info) { for my $fields (keys %{$function_info[$keys]}) { $msg = "$keys $fields $function_info[$keys]{$fields}"; gp_message ("debugXL", $subr_name, $msg); } } for my $i (keys %addressobjtextm) { $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i}; gp_message ("debugXL", $subr_name, $msg); } $msg = "generate the files with function overviews and the"; $msg .= " callers-callees information"; gp_message ("verbose", $subr_name, $msg); $script_pc_metrics = generate_function_level_info (\@exp_dir_list, $call_metrics, $summary_metrics, $outputdir, $sort_fields_ref); $msg = "preprocess the files with the function level information"; gp_message ("verbose", $subr_name, $msg); $ignore_value = preprocess_function_files ( $metric_description_ref, $script_pc_metrics, $outputdir, \@sort_fields); $msg = "for each function, generate a set of files"; gp_message ("verbose", $subr_name, $msg); ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files (\@exp_dir_list, $executable_name, $time_percentage_multiplier, $summary_metrics, $process_all_functions, $elf_loadobjects_found, $outputdir, \@sort_fields, \@function_info, \%function_address_and_index, \%LINUX_vDSO, \%metric_description, $elf_arch, $base_va_executable, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats); @function_info = @{ $function_info_ref }; %function_address_info = %{ $function_address_info_ref }; %addressobj_index = %{ $addressobj_index_ref }; #------------------------------------------------------------------------------ # Parse the disassembly information and generate the html files. #------------------------------------------------------------------------------ $msg = "parse the disassembly files and generate the html files"; gp_message ("verbose", $subr_name, $msg); $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info, \%function_address_and_index, \$outputdir, \%addressobj_index); #------------------------------------------------------------------------------ # Parse the source information and generate the html files. #------------------------------------------------------------------------------ $msg = "parse the source files and generate the html files"; gp_message ("verbose", $subr_name, $msg); parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); #------------------------------------------------------------------------------ # Parse the caller-callee information and generate the html files. #------------------------------------------------------------------------------ $msg = "process the caller-callee information and generate the html file"; gp_message ("verbose", $subr_name, $msg); #------------------------------------------------------------------------------ # Generate the caller-callee information. #------------------------------------------------------------------------------ $ignore_value = generate_caller_callee (\$number_of_metrics, \@function_info, \%function_view_structure, \%function_address_info, \%addressobjtextm, \$outputdir); #------------------------------------------------------------------------------ # Parse the calltree information and generate the html files. #------------------------------------------------------------------------------ if ($g_user_settings{"calltree"}{"current_value"} eq "on") { $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); } #------------------------------------------------------------------------------ # Process the metric values. #------------------------------------------------------------------------------ $msg = "generate the html file with the metrics information"; gp_message ("verbose", $subr_name, $msg); $ignore_value = process_metrics ($outputdir, \@sort_fields, \%metric_description, \%ignored_metrics); #------------------------------------------------------------------------------ # Generate the function view html files. #------------------------------------------------------------------------------ $msg = "generate the function view html files"; gp_message ("verbose", $subr_name, $msg); $html_first_metric_file_ref = generate_function_view ( \$outputdir, \$summary_metrics, \$number_of_metrics, \@function_info, \%function_view_structure, \%function_address_info, \@sort_fields, \@exp_dir_list, \%addressobjtextm); $html_first_metric_file = ${ $html_first_metric_file_ref }; $msg = "html_first_metric_file = " . $html_first_metric_file; gp_message ("debugXL", $subr_name, $msg); $html_test = ${ generate_home_link ("left") }; $msg = "html_test = " . $html_test; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Unconditionnaly generate the page with the warnings. #------------------------------------------------------------------------------ $ignore_value = html_create_warnings_page (\$outputdir); #------------------------------------------------------------------------------ # Generate the index.html file. #------------------------------------------------------------------------------ $msg = "generate the index.html file"; gp_message ("verbose", $subr_name, $msg); $ignore_value = html_generate_index (\$outputdir, \$html_first_metric_file, \$summary_metrics, \$number_of_metrics, \@function_info, \%function_address_info, \@sort_fields, \@exp_dir_list, \%addressobjtextm, \%metric_description_reversed, \@table_execution_stats); #------------------------------------------------------------------------------ # We're done. In debug mode, print the meta data for the experiment # directories. #------------------------------------------------------------------------------ $ignore_value = print_meta_data_experiments ("debug"); #------------------------------------------------------------------------------ # Before the execution completes, print the warning(s) on the screen. # # Note that this assumes that no additional warnings have been created since # the call to html_create_warnings_page. Otherwise there will be a discrepancy # between what is printed on the screen and shown in the warnings.html page. #------------------------------------------------------------------------------ if (($g_total_warning_count > 0) and ($g_warnings)) { $ignore_value = print_warnings_buffer (); @g_warning_msgs = (); } #------------------------------------------------------------------------------ # This is not supposed to happen, but in case there are any fatal errors that # have not caused the execution to terminate, print them here. #------------------------------------------------------------------------------ if (@g_error_msgs) { $ignore_value = print_errors_buffer (\$g_error_keyword); } #------------------------------------------------------------------------------ # One line message to show where the results can be found. #------------------------------------------------------------------------------ my $results_file = $abs_path_outputdir . "/index.html"; my $prologue_text = "Processing completed - view file $results_file" . " in a browser"; gp_message ("diag", $subr_name, $prologue_text); return (0); } #-- End of subroutine main #------------------------------------------------------------------------------ # If it is not present, add a "/" to the name of the argument. This is # intended to be used for the name of the output directory and makes it # 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 $msg; 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 { $msg = "g_addressing_mode = $g_addressing_mode not supported"; gp_message ("abort", $subr_name, $msg); } $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. # # First, it is checked if the command is in the search path, built-in, or an # alias. If this is not the case, search for it in a couple of locations. # # If this all fails, warning messages are printed, but this is not a hard # error. Yet. Most likely, things will go bad later on. # # The commands and their respective paths are stored in hash "g_mapped_cmds". #------------------------------------------------------------------------------ sub check_and_define_cmds { 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 @the_fields = (); my $cmd; my $cmd_found; my $error_code; my $failed_cmd; my $failed_cmds; my $found_match; my $mapped; my $msg; my $no_of_failed_mappings; my $no_of_fields; my $output_cmd; my $target_cmd; my $failed_mapping = $FALSE; my $full_path_cmd; gp_message ("debugXL", $subr_name, "\@cmds = @cmds"); gp_message ("debugXL", $subr_name, "\@search_path = @search_path"); #------------------------------------------------------------------------------ # Search for the command and record the absolute path. In case no such path # can be found, the entry in $g_mapped_cmds is assigned a special value that # will be checked for in the next block. #------------------------------------------------------------------------------ for $cmd (@cmds) { $target_cmd = "(command -v $cmd; echo \$\?)"; ($error_code, $output_cmd) = execute_system_cmd ($target_cmd); if ($error_code != 0) #------------------------------------------------------------------------------ # This is unlikely to happen, since it means the command executed failed. #------------------------------------------------------------------------------ { $msg = "error executing this command: " . $target_cmd; gp_message ("warning", $subr_name, $msg); $msg = "execution continues, but may fail later on"; gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; } else #------------------------------------------------------------------------------ # So far, all is well, but is the target command available? #------------------------------------------------------------------------------ { #------------------------------------------------------------------------------ # The output from the $target_cmd command should contain 2 lines in case the # command has been found. The first line shows the command with the full # path, while the second line has the exit code. # # If the exit code is not zero, the command has not been found. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Split the output at the \n character and check the number of lines as # well as the return code. #------------------------------------------------------------------------------ @the_fields = split ("\n", $output_cmd); $no_of_fields = scalar (@the_fields); $cmd_found = ($the_fields[$no_of_fields-1] == 0 ? $TRUE : $FALSE); #------------------------------------------------------------------------------ # This is unexpected. Throw an assertion error and bail out. #------------------------------------------------------------------------------ if ($no_of_fields > 2) { gp_message ("error", $subr_name, "output from $target_cmd:"); gp_message ("error", $subr_name, $output_cmd); $msg = "the output from $target_cmd has more than 2 lines"; gp_message ("assertion", $subr_name, $msg); } if ($cmd_found) { $full_path_cmd = $the_fields[0]; #------------------------------------------------------------------------------ # The command is in the search path. Store the full path to the command. #------------------------------------------------------------------------------ $msg = "the $cmd command is in the search path"; gp_message ("debug", $subr_name, $msg); $g_mapped_cmds{$cmd} = $full_path_cmd; } else #------------------------------------------------------------------------------ # A best effort to locate the command elsewhere. If found, store the command # with the absolute path included. Otherwise print a warning, but continue. #------------------------------------------------------------------------------ { $msg = "the $cmd command is not in the search path"; $msg .= " - start a best effort search to find it"; gp_message ("debug", $subr_name, $msg); $found_match = $FALSE; for my $path (@search_path) { $target_cmd = $path . "/" . $cmd; if (-x $target_cmd) { $msg = "found the command in $path"; gp_message ("debug", $subr_name, $msg); $found_match = $TRUE; $g_mapped_cmds{$cmd} = $target_cmd; last; } else { $msg = "failure to find the $cmd command in $path"; gp_message ("debug", $subr_name, $msg); } } if (not $found_match) { $g_mapped_cmds{$cmd} = "road to nowhere"; $failed_mapping = $TRUE; } } } } #------------------------------------------------------------------------------ # Scan the results stored in $g_mapped_cmds and flag errors. #------------------------------------------------------------------------------ $no_of_failed_mappings = 0; $failed_cmds = ""; #------------------------------------------------------------------------------ # Print a warning message before showing the results, that at least one search # has failed. #------------------------------------------------------------------------------ if ($failed_mapping) { $msg = "<br>" . "failure in the verification of the OS commands:"; gp_message ("warning", $subr_name, $msg); } while ( ($cmd, $mapped) = each %g_mapped_cmds) { if ($mapped eq "road to nowhere") { $msg = "cannot find a path for command $cmd"; gp_message ("warning", $subr_name, $msg); gp_message ("debug", $subr_name, $msg); $no_of_failed_mappings++; $failed_cmds .= $cmd; $g_mapped_cmds{$cmd} = $cmd; } else { $msg = "path for the $cmd command is $mapped"; gp_message ("debug", $subr_name, $msg); } } if ($no_of_failed_mappings != 0) { my $plural_1 = ($no_of_failed_mappings > 1) ? "failures" : "failure"; my $plural_2 = ($no_of_failed_mappings > 1) ? "commands" : "command"; $msg = "encountered $no_of_failed_mappings $plural_1 to locate"; $msg .= " selected " . $plural_2; gp_message ("warning", $subr_name, $msg); gp_message ("debug", $subr_name, $msg); $msg = "execution continues, but may fail later on"; gp_message ("warning", $subr_name, $msg); gp_message ("debug", $subr_name, $msg); $g_total_warning_count++; } return ($no_of_failed_mappings); } #-- 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; $msg = "cannot determine branch target"; gp_message ("debug", $subr_name, $msg); } } 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}"; $msg .= " = $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 if the value for the user option given is valid. # # In case the value is valid, the g_user_settings table is updated with the # (new) value. # # Otherwise an error message is pushed into the g_error_msgs buffer. # # The return value is TRUE/FALSE. #------------------------------------------------------------------------------ sub check_and_set_user_option { my $subr_name = get_my_name (); my ($internal_opt_name, $value) = @_; my $msg; my $valid; my $option_value_missing; my $option = $g_user_settings{$internal_opt_name}{"option"}; my $data_type = $g_user_settings{$internal_opt_name}{"data_type"}; my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"}; if (($no_of_args >= 1) and ((not defined ($value)) or (length ($value) == 0))) #------------------------------------------------------------------------------ # If there was no value given, but it is required, flag an error. # There could also be a value, but it might be the empty string. # # Note that that there are currently no options with multiple values. Should # these be introduced, the current check may need to be refined. #------------------------------------------------------------------------------ { $valid = $FALSE; $option_value_missing = $TRUE; } elsif ($no_of_args >= 1) { $option_value_missing = $FALSE; #------------------------------------------------------------------------------ # There is an input value. Check if it is valid and if so, store it. # # Note that we allow the options to be case insensitive. #------------------------------------------------------------------------------ $valid = verify_if_input_is_valid ($value, $data_type); if ($valid) { if (($data_type eq "onoff") or ($data_type eq "size")) { $g_user_settings{$internal_opt_name}{"current_value"} = lc ($value); } else { $g_user_settings{$internal_opt_name}{"current_value"} = $value; } $g_user_settings{$internal_opt_name}{"defined"} = $TRUE; } } return (\$valid, \$option_value_missing); } #-- End of subroutine check_and_set_user_option #------------------------------------------------------------------------------ # Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool # needed to provide the information. If it can not be found, execution is # terminated. # # We first search for this tool in the current execution directory. If it # cannot be found there, use $PATH to try to locate it. #------------------------------------------------------------------------------ sub check_availability_tool { my $subr_name = get_my_name (); my ($location_gp_command_ref) = @_; my $error_code; my $error_occurred; my $gp_path; 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, $gp_path_ref, $return_value_ref) = find_path_to_gp_display_text ($location_gp_command_ref); $error_occurred = ${ $error_occurred_ref}; $gp_path = ${ $gp_path_ref }; $return_value = ${ $return_value_ref}; $msg = "error_occurred = $error_occurred return_value = $return_value"; gp_message ("debugXL", $subr_name, $msg); if (not $error_occurred) #------------------------------------------------------------------------------ # All is well and gp-display-text has been located. #------------------------------------------------------------------------------ { $g_path_to_tools = $return_value; $msg = "located $GP_DISPLAY_TEXT in the execution directory"; gp_message ("debug", $subr_name, $msg); $msg = "g_path_to_tools = $g_path_to_tools"; gp_message ("debug", $subr_name, $msg); } else #------------------------------------------------------------------------------ # Something went wrong, but perhaps we can still continue. Try to find # $GP_DISPLAY_TEXT through the search path. #------------------------------------------------------------------------------ { $msg = $g_html_new_line; $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :"; $msg .= " $return_value"; gp_message ("warning", $subr_name, $msg); #------------------------------------------------------------------------------ # Check if we can find $GP_DISPLAY_TEXT in the search path. #------------------------------------------------------------------------------ $msg = "check for $GP_DISPLAY_TEXT to be in the search path"; gp_message ("debug", $subr_name, $msg); gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; ($error_code, $output_which_gp_display_text) = execute_system_cmd ($target_cmd); 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 = "located $GP_DISPLAY_TEXT in $g_path_to_tools"; gp_message ("warning", $subr_name, $msg); $msg = "this is the version that will be used"; gp_message ("warning", $subr_name, $msg); $msg = "the $GP_DISPLAY_TEXT tool is in the search path"; gp_message ("debug", $subr_name, $msg); $msg = "g_path_to_tools = $g_path_to_tools"; gp_message ("debug", $subr_name, $msg); } else { $msg = "failure to find $GP_DISPLAY_TEXT in the search path"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_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 $event_kind_map_regex; $event_kind_map_regex = '^<event kind="map"\s.*vaddr='; $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset='; $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes='; $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$'; my $hostname_current = $local_system_config{"hostname_current"}; my $arch = $local_system_config{"processor"}; my $arch_uname_s = $local_system_config{"kernel_name"}; my $extracted_information; my $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 $msg; 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. #------------------------------------------------------------------------------ $msg = " - unable to open file $path_to_log_file for reading:"; open (LOG_XML, "<", $path_to_log_file) or die ($subr_name . $msg . " " . $!); $msg = "opened file $path_to_log_file for reading"; gp_message ("debug", $subr_name, $msg); while (<LOG_XML>) { $line = $_; chomp ($line); gp_message ("debugM", $subr_name, "read line: $line"); #------------------------------------------------------------------------------ # Search for the first line starting with "<system". Bail out if found and # parsed. These are two examples: # <system hostname="ruud-vm" arch="x86_64" \ # os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> #------------------------------------------------------------------------------ if ($line =~ /^\s*<system\s+/) { $msg = "selected the following line from the log.xml file:"; gp_message ("debugM", $subr_name, $msg); gp_message ("debugM", $subr_name, "$line"); if ($line =~ /.*\s+hostname="([^"]+)/) { $hostname_exp = $1; $msg = "extracted hostname_exp = " . $hostname_exp; gp_message ("debugM", $subr_name, $msg); } if ($line =~ /.*\s+arch="([^"]+)/) { $arch_exp = $1; $msg = "extracted arch_exp = " . $arch_exp; gp_message ("debugM", $subr_name, $msg); } if ($line =~ /.*\s+os="([^"]+)/) { $os_exp_full = $1; #------------------------------------------------------------------------------ # Capture the first word only. #------------------------------------------------------------------------------ if ($os_exp_full =~ /([^\s]+)/) { $os_exp = $1; } $msg = "extracted os_exp = " . $os_exp; gp_message ("debugM", $subr_name, $msg); } 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)) { $msg = "early return: the hostname, architecture and OS match"; $msg .= " the current system"; gp_message ("debug", $subr_name, $msg); $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE"; gp_message ("debug", $subr_name, $msg); # FAKE return ($TRUE); } if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) { $msg = "selected_archive = " . $selected_archive; gp_message ("debug", $subr_name, $msg); for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) { $msg = "stored loadobject " . $i . " "; $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i}; gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Check if the selected experiment directory has archived files in ELF format. # If not, use the information in map.xml to get the name of the executable # and the virtual address. #------------------------------------------------------------------------------ if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) { $msg = "the files in directory $selected_archive/archives are in"; $msg .= " ELF format"; gp_message ("debugM", $subr_name, $msg); $msg = "IGNORE THIS AND USE MAP.XML"; gp_message ("debugM", $subr_name, $msg); ## return ($TRUE); } $msg = "the files in directory $selected_archive/archives are not in"; $msg .= " ELF format"; gp_message ("debug", $subr_name, $msg); $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; $path_to_map_file .= $selected_archive; $path_to_map_file .= "/map.xml"; $msg = " - unable to open file $path_to_map_file for reading:"; open (MAP_XML, "<", $path_to_map_file) or die ($subr_name . $msg . " " . $!); $msg = "opened file $path_to_map_file for reading"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Scan the map.xml file. We need to find the name of the executable with the # mode set to 0x005. For this entry we have to capture the virtual address. #------------------------------------------------------------------------------ $extracted_information = $FALSE; while (<MAP_XML>) { $line = $_; chomp ($line); gp_message ("debugM", $subr_name, "MAP_XML read line = $line"); #------------------------------------------------------------------------------ # Replaces this way too long line: # if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+. # *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.* # name="(.*)".*>$/) #------------------------------------------------------------------------------ if ($line =~ /$event_kind_map_regex/) { gp_message ("debugM", $subr_name, "target line = $line"); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); $msg = "extracted vaddr = $vaddr foffset = $foffset"; $msg .= " modes = $modes"; gp_message ("debugM", $subr_name, $msg); $msg = "extracted name_path = $name_path name = $name"; gp_message ("debugM", $subr_name, $msg); # $error_extracting_information = $TRUE; $executable_name = $name; my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); my $hex_VA = sprintf ("0x%016x", $result_VA); $va_executable_in_hex = $hex_VA; $msg = "set executable_name = " . $executable_name; gp_message ("debugM", $subr_name, $msg); $msg = "set va_executable_in_hex = " . $va_executable_in_hex; gp_message ("debugM", $subr_name, $msg); $msg = "result_VA = " . $result_VA; gp_message ("debugM", $subr_name, $msg); $msg = "hex_VA = " . $hex_VA; gp_message ("debugM", $subr_name, $msg); if ($modes eq "005") { $extracted_information = $TRUE; last; } } } close (MAP_XML); if (not $extracted_information) { $msg = "cannot find the necessary information in"; $msg .= " 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 $msg; 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]; $msg = "metric = $metric current_value = $current_value"; $msg .= " max_value = $max_value"; gp_message ("debugXL", $subr_name, $msg); if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) { # TBD: abs needed? $msg = "metric = $metric current_value = $current_value"; $msg .= " max_value = $max_value"; gp_message ("debugXL", $subr_name, $msg); $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); $msg = "relative_distance = $relative_distance"; gp_message ("debugXL", $subr_name, $msg); if ($relative_distance >= $hp_value/100.0) { $msg = "metric $metric is within the relative_distance"; gp_message ("debugXL", $subr_name, $msg); $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 the command line options for the occurrence of experiments and make # sure that this list is contigious. No other names are allowed in this list. # # Terminate execution in case of an error. Otherwise remove the experiment # names for ARGV (to make the subsequent parsing easier), and return an array # with the experiment names. # # The following patterns are supposed to be detected: # # <expdir_1> some other word(s) <expdir_2> # <expdir> some other word(s) #------------------------------------------------------------------------------ sub check_the_experiment_list { my $subr_name = get_my_name (); #------------------------------------------------------------------------------ # The name of an experiment directory can contain any non-whitespace # character(s), but has to end with .er, or optionally .er/. Multiple # forward slashes are allowed. #------------------------------------------------------------------------------ my $exp_dir_regex = '^(\S+)(\.er)\/*$'; my $forward_slash_regex = '\/*$'; my $current_value; my @exp_dir_list = (); my $found_experiment = $FALSE; my $found_non_exp = $FALSE; my $msg; my $name_non_exp_dir = ""; my $no_of_experiments = 0; my $no_of_invalid_dirs = 0; my $opt_remainder; my $valid = $TRUE; for my $i (keys @ARGV) { $current_value = $ARGV[$i]; if ($current_value =~ /$exp_dir_regex/) #------------------------------------------------------------------------------ # The current value is an experiment. Remove any trailing forward slashes, # Increment the count, push the value into the array and set the # found_experiment flag to TRUE. #------------------------------------------------------------------------------ { $no_of_experiments += 1; $current_value =~ s/$forward_slash_regex//; push (@exp_dir_list, $current_value); if (not $found_experiment) #------------------------------------------------------------------------------ # Start checking for the next field(s). #------------------------------------------------------------------------------ { $found_experiment = $TRUE; } #------------------------------------------------------------------------------ # We had found non-experiment names and now see another experiment. Time to # bail out of the loop. #------------------------------------------------------------------------------ if ($found_non_exp) { last; } } else { if ($found_experiment) #------------------------------------------------------------------------------ # The current value is not an experiment, but the value of found_experiment # indicates at least one experiment has been seen already. This means that # the list of experiment names is not contiguous and that is a fatal error. #------------------------------------------------------------------------------ { $name_non_exp_dir .= $current_value . " "; $found_non_exp = $TRUE; } } } #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Error handling. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ if ($found_non_exp) #------------------------------------------------------------------------------ # The experiment list is not contiguous. #------------------------------------------------------------------------------ { $valid = $FALSE; $msg = "the list with the experiments is not contiguous:"; gp_message ("error", $subr_name, $msg); $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" . " appears in a list where experiments are expected"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } if ($no_of_experiments == 0) #------------------------------------------------------------------------------ # The experiment list is empty. #------------------------------------------------------------------------------ { $valid = $FALSE; $msg = "the experiment list is missing from the options"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } if (not $valid) #------------------------------------------------------------------------------ # If an error has occurred, print the error(s) and terminate execution. #------------------------------------------------------------------------------ { gp_message ("abort", $subr_name, $g_abort_msg); } #------------------------------------------------------------------------------ # We now have a list with experiments, but we still need to verify whether they # exist, and if so, are these valid experiments? #------------------------------------------------------------------------------ for my $exp_dir (@exp_dir_list) { $msg = "checking experiment directory $exp_dir"; gp_message ("debug", $subr_name, $msg); if (-d $exp_dir) { $msg = "directory $exp_dir found"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Files log.xml and map.xml have to be there. #------------------------------------------------------------------------------ if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) { $msg = "directory $exp_dir appears to be a valid experiment"; $msg .= " directory"; gp_message ("debug", $subr_name, $msg); } else { $no_of_invalid_dirs++; $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir; $msg .= "/map.xml missing"; gp_message ("debug", $subr_name, $msg); $msg = "directory " . get_basename($exp_dir) . " does not"; $msg .= " appear to be a valid experiment directory"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } } else { $no_of_invalid_dirs++; $msg = "directory " . get_basename($exp_dir) . " does not exist"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } } if ($no_of_invalid_dirs > 0) #------------------------------------------------------------------------------ # This is a fatal error, but for now, we can continue to check for more errors. # Even if none more are found, execution is terminated before the data is # generated and processed. In this way we can catch as many errors as # possible. #------------------------------------------------------------------------------ { my $plural_or_single = ($no_of_invalid_dirs == 1) ? "one experiment is" : $no_of_invalid_dirs . " experiments are"; $msg = $plural_or_single . " not valid"; ## gp_message ("abort", $subr_name, $msg); ## $g_total_error_count++; } #------------------------------------------------------------------------------ # Remove the experiments from ARGV and return the array with the experiment # names. Note that these may, or may not be valid, but if invalid, execution # terminates before they are used. #------------------------------------------------------------------------------ for my $i (1 .. $no_of_experiments) { my $poppy = pop (@ARGV); $msg = "popped $poppy from ARGV"; gp_message ("debug", $subr_name, $msg); $msg = "ARGV after update = " . join (" ", @ARGV); gp_message ("debug", $subr_name, $msg); } return (\@exp_dir_list); } #-- End of subroutine check_the_experiment_list #------------------------------------------------------------------------------ # Perform multiple checks on the experiment directories. # # TBD: It needs to be investigated whether all of this is really neccesary. #------------------------------------------------------------------------------ sub check_validity_exp_dirs { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my %elf_rats = (); my $dir_not_found = $FALSE; my $missing_dirs = 0; my $invalid_dirs = 0; my $archive_dir_not_empty; my $archives_dir; my $archives_file; my $count_exp_dir_not_elf; my $elf_magic_number; my $first_line; my $msg; my $first_time; my $filename; my $comment; my $selected_archive_has_elf_format; my $selected_archive; my $archive_dir_selected; my $no_of_files_in_selected_archive; #------------------------------------------------------------------------------ # 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"}; $archives_dir .= $exp_dir . "/archives"; $archive_dir_not_empty = $FALSE; $first_time = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}; gp_message ("debug", $subr_name, $msg); $msg = "checking $archives_dir"; gp_message ("debug", $subr_name, $msg); while (glob ("$archives_dir/*")) { $filename = get_basename ($_); $msg = "processing file: $filename"; gp_message ("debug", $subr_name, $msg); $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; $archive_dir_not_empty = $TRUE; #------------------------------------------------------------------------------ # Replaces the ELF_RATS part in elf_phdr. # # Challenge: splittable_mrg.c_I0txnOW_Wn5 # # TBD: Store this for each relevant experiment directory. #------------------------------------------------------------------------------ my $last_dot = rindex ($filename,"."); my $underscore_before_dot = $TRUE; my $first_underscore = -1; $msg = "last_dot = $last_dot"; gp_message ("debugXL", $subr_name, $msg); 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); $msg = "stripped archive name: " . $original_name; gp_message ("debug", $subr_name, $msg); if (not exists ($elf_rats{$original_name})) { $elf_rats{$original_name} = [$filename, $exp_dir]; } #------------------------------------------------------------------------------ # We only need to detect the presence of an object once. #------------------------------------------------------------------------------ if ($first_time) { $first_time = $FALSE; $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; gp_message ("debugXL", $subr_name, $msg); } } } #-- End of loop over experiment directories for my $exp_dir (sort keys %g_exp_dir_meta_data) { my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; $msg = "archive directory " . $exp_dir . "/archives is"; $msg .= " " . ($empty ? "empty" : "not empty"); gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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"}; $archives_dir .= $exp_dir . "/archives"; $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Check if any of the loadobjects is of type ELF. Bail out on the first one # found. The assumption is that all other loadobjects must be of type ELF too # then. #------------------------------------------------------------------------------ for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; $filename .= $exp_dir . "/archives/" . $aname; $msg = " - unable to open file $filename for reading:"; open (ARCF,"<", $filename) or die ($subr_name . $msg . " " . $!); $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); 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) { $msg = "the loadobjects in the archive in $exp_dir are"; $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? " in" : " not in"; $msg .= " ELF format"; gp_message ("debug", $subr_name, $msg); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $msg = "there are no archived files in " . $exp_dir; gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ # If there are archived files and they are not in ELF format, a debug message # 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) { $msg = "there are $count_exp_dir_not_elf experiments with non-ELF"; $msg .= " load objects"; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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) { $msg = "exp_dir = " . $exp_dir; gp_message ("debugXL", $subr_name, $msg); $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"; $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; gp_message ("debugXL", $subr_name, $msg); if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { $selected_archive = $exp_dir; $archive_dir_not_empty = $TRUE; $archive_dir_selected = $TRUE; $selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE; 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; } } } $msg = "experiment $selected_archive has been selected for"; $msg .= " archive analysis"; gp_message ("debug", $subr_name, $msg); $msg = "this archive is"; $msg .= $archive_dir_not_empty ? " not empty" : " empty"; gp_message ("debug", $subr_name, $msg); $msg = "this archive is"; $msg .= $selected_archive_has_elf_format ? " in" : " not in"; $msg .= " ELF format"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Get the size of the hash that contains the archived files. #------------------------------------------------------------------------------ ## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; $msg = "number of files in archive $selected_archive is"; $msg .= " " . $no_of_files_in_selected_archive; gp_message ("debug", $subr_name, $msg); for my $exp_dir (sort keys %g_exp_dir_meta_data) { my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; $msg = "archive directory $exp_dir/archives is"; $msg .= $is_empty ? " empty" : " not empty"; gp_message ("debug", $subr_name, $msg); } for my $exp_dir (sort keys %g_exp_dir_meta_data) { if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) { for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) { $msg = $exp_dir . " " . $object . " "; $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}; gp_message ("debug", $subr_name, $msg); } } } return ($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 $msg; my $plural; $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; $experiment_stats_line = "<h3>\n"; $experiment_stats_line .= "Full pathnames to the input experiment"; $experiment_stats_line .= $plural . "\n"; $experiment_stats_line .= "</h3>\n"; $experiment_stats_line .= "<pre>\n"; for my $i (0 .. $#experiment_dir_list) { $experiment_stats_line .= $experiment_dir_list[$i] . " (" ; $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n"; } $experiment_stats_line .= "</pre>\n"; push (@experiment_stats_html, $experiment_stats_line); $msg = "experiment_stats_line = " . $experiment_stats_line; gp_message ("debugXL", $subr_name, $msg); 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\""; $html_header .= " content=\"text/html; charset=iso-8859-1\">\n"; $html_header .= "<title>" . $title . "</title>\n"; $html_header .= "</head>\n"; $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; $html_header .= "<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 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 }; my $html_line; my $msg; $msg = "entry_name = $entry_name key = $key"; gp_message ("debugXL", $subr_name, $msg); ## $html_line = "<tr><div class=\"left\"><td><b>  "; $html_line = "<tr><div class=\"right\"><td><b>  "; $html_line .= $entry_name; $html_line .= "  </b></td>"; for my $i (sort keys @experiment_data) { if (exists ($experiment_data[$i]{$key})) { $html_line .= "<td>  " . $experiment_data[$i]{$key}; $html_line .= "  </td>"; } else { $msg = "experiment_data[$i]{$key} does not exist"; ## gp_message ("assertion", $subr_name, $msg); # TBD: warning or error? gp_message ("warning", $subr_name, $msg); } } $html_line .= "</div></tr>\n"; 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; my $msg; $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 "; $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>"; } $html_header_line .= "</div></tr>\n"; $msg = "html_header_line = " . $html_header_line; gp_message ("debugXL", $subr_name, $msg); return (\$html_header_line); } #-- End of subroutine create_table_header_exp #------------------------------------------------------------------------------ # Handle where the output should go. If needed, a directory is created where # the results will go. #------------------------------------------------------------------------------ sub define_the_output_directory { my $subr_name = get_my_name (); my ($define_new_output_dir, $overwrite_output_dir) = @_; my $msg; my $outputdir; #------------------------------------------------------------------------------ # If neither -o or -O are set, find the next number to be used in the name for # 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) { $msg = "directory $outputdir already exists"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; $msg = "use the -O/--overwrite option to overwrite an existing"; $msg .= " directory"; gp_message ("abort", $subr_name, $msg); } #------------------------------------------------------------------------------ # This is a bit risky, so we proceed with caution. The output directory exists, # but it is okay to overwrite it. It is removed here and created again below. #------------------------------------------------------------------------------ elsif ($overwrite_output_dir) { my $target_cmd = $g_mapped_cmds{"rm"}; 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); $msg = "fatal error when trying to remove " . $outputdir; gp_message ("abort", $subr_name, $msg); } else { $msg = "directory $outputdir has been removed"; gp_message ("debug", $subr_name, $msg); } } } #------------------------------------------------------------------------------ # When we get here, the fatal scenarios have been cleared and the name for # $outputdir is known. Time to create it. #------------------------------------------------------------------------------ if (mkdir ($outputdir, 0777)) { $msg = "created output directory " . $outputdir; gp_message ("debug", $subr_name, $msg); } else { $msg = "a fatal problem occurred when creating directory " . $outputdir; gp_message ("abort", $subr_name, $msg); } 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 $msg; my $name_loadobject; my $base_va_address; $msg = "base_va_executable = " . $base_va_executable; gp_message ("debugXL", $subr_name, $msg); $msg = "loadobj = " . $loadobj; gp_message ("debugXL", $subr_name, $msg); $msg = "routine = " . $routine; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Strip the pathname from the load object name. #------------------------------------------------------------------------------ $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); $msg = "return base_va_address = $base_va_address"; $msg .= " (decimal: $decimal_address)"; gp_message ("debugXL", $subr_name, $msg); return ($base_va_address); } #-- End of subroutine determine_base_va_address #------------------------------------------------------------------------------ # Now that we know the map.xml file(s) are present, we can scan these and get # the required information. #------------------------------------------------------------------------------ sub determine_base_virtual_address { my $subr_name = get_my_name (); my ($exp_dir_list_ref) = @_; my @exp_dir_list = @{ $exp_dir_list_ref }; my $executable_name; my $full_path_exec; my $msg; my $path_to_map_file; my $va_executable_in_hex; 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; $msg = "exp_dir = " . $exp_dir; gp_message ("debug", $subr_name, $msg); $msg = "full_path_exece = " . $full_path_exec; gp_message ("debug", $subr_name, $msg); $msg = "executable_name = " . $executable_name; gp_message ("debug", $subr_name, $msg); $msg = "va_executable_in_hex = " . $va_executable_in_hex; gp_message ("debug", $subr_name, $msg); } return (0); } #-- 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 $cmd_output; my $convert_to_dot; my $decimal_separator; my $error_code; my $field; my $ignore_count; my @locale_info = (); my $msg; my $target_cmd; my $target_found; my $default_decimal_separator = "\\."; $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC"; ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); if ($error_code != 0) #------------------------------------------------------------------------------ # This is unlikely to happen, but you never know. To reduce the nesting level, # return right here in case of an error. #------------------------------------------------------------------------------ { $msg = "failure to execute the command " . $target_cmd; gp_message ("error", $subr_name, $msg); $g_total_error_count++; $convert_to_dot = $TRUE; return ($error_code, $default_decimal_separator, $convert_to_dot); } #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Scan the locale info and search for the target line of the form # 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); $msg = "line from locale_info = " . $line; gp_message ("debug", $subr_name, $msg); if ($line =~ /decimal_point=/) { #------------------------------------------------------------------------------ # Found the target line. Split this line to get the value field. #------------------------------------------------------------------------------ my @split_line = split ("=", $line); #------------------------------------------------------------------------------ # 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); $msg = "line $line matches the search, but the decimal"; $msg .= " separator has the wrong format"; gp_message ("warning", $subr_name, $msg); $msg = "the splitted line is [@split_line] and does not"; $msg .= " contain 2 fields"; gp_message ("warning", $subr_name, $msg); $msg = "the default decimal separator will be used"; gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; } else { #------------------------------------------------------------------------------ # We know there are 2 fields and the second one has the decimal point. #------------------------------------------------------------------------------ $msg = "split_line[1] = " . $split_line[1]; gp_message ("debug", $subr_name, $msg); chomp ($split_line[1]); $field = $split_line[1]; if (length ($field) != 3) #------------------------------------------------------------------------------ # The field still includes the quotes. Check if the string has length 3, which # should be the case, but if not, we flag an error. The error code is set such # that the callee will know a problem has occurred. #------------------------------------------------------------------------------ { $msg = "unexpected output from the $target_cmd command:"; $msg .= " " . $field; gp_message ("error", $subr_name, $msg); $g_total_error_count++; $error_code = 1; last; } $msg = "field = ->$field<-"; gp_message ("debug", $subr_name, $msg); if (($field eq "\".\"") or ($field eq "\",\"")) #------------------------------------------------------------------------------ # Found the separator. Capture the character between the quotes. #------------------------------------------------------------------------------ { $target_found = $TRUE; $decimal_separator = substr ($field,1,1); $msg = "decimal_separator = $decimal_separator--end"; $msg .= " skip remainder of loop"; gp_message ("debug", $subr_name, $msg); last; } } } } if (not $target_found) { $decimal_separator = $default_decimal_separator; $msg = "cannot determine the decimal separator"; $msg .= " - use the default " . $decimal_separator; gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; } if ($decimal_separator ne ".") { $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; my $msg; $msg = "function_info for " . $name; gp_message ("debug", $subr_name, $msg); $kip = 0; for my $farray ($function_info{$name}) { for my $elm (@{$farray}) { $msg = $kip . ": routine = " . ${$elm}{"routine"}; gp_message ("debug", $subr_name, $msg); for my $key (sort keys %{$elm}) { if ($key eq "routine") { next; } $msg = $kip . ": $key = " . ${$elm}{$key}; gp_message ("debug", $subr_name, $msg); } $kip++; } } return (0); } #-- End of subroutine dump_function_info #------------------------------------------------------------------------------ # 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 $msg; my $return_value; #------------------------------------------------------------------------------ # TBD. Quick check. Can be moved up the call tree. #------------------------------------------------------------------------------ if ( $elf_arch ne "Linux" ) { $msg = $elf_arch . " is not a supported OS"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } #------------------------------------------------------------------------------ # 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) { $msg = "need to handle a return value of FALSE"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } return ($return_value); } #-- End of subroutine elf_phdr #------------------------------------------------------------------------------ # 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 $cmd_output; my $command_string; my $error_code; my $msg; my $target_cmd; 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 #------------------------------------------------------------------------------ $msg = "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"; gp_message ("debug", $subr_name, $msg); return ($FALSE); } if ($loadobj eq "DYNAMIC_FUNCTIONS") #------------------------------------------------------------------------------ # Linux vDSO, leave for now #------------------------------------------------------------------------------ { 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 $load_long_regex; $load_long_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)'; $load_long_regex .= '\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; my $load_short_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$'; my $re_regex = '^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; my $return_code; my $cmd_output; my $target_cmd; my $command_string; my $error_code; my $error_code1; my $error_code2; my $msg; 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"}; $msg = "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"; gp_message ("debug", $subr_name, $msg); my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj); $msg = "base = $base " . basename ($loadobj); gp_message ("debug", $subr_name, $msg); 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 #------------------------------------------------------------------------------ $msg = "masquerading arch_uname_s->" . $arch_uname_s; $msg .= " elf_arch->" . $elf_arch; gp_message ("debug", $subr_name, $msg); return ($FALSE); } if ($loadobj eq "DYNAMIC_FUNCTIONS") { #------------------------------------------------------------------------------ # 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); $msg = "executed command_string = " . $command_string; gp_message ("debug", $subr_name, $msg); $msg = "cmd_output = " . $cmd_output; gp_message ("debug", $subr_name, $msg); if ($error_code1 != 0) { 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; $elfoid = $elf_rats{$loadobjARC}[1] . "/archives/"; $elfoid .= $elf_rats{$loadobjARC}[0]; $target_cmd = $g_mapped_cmds{"readelf"}; $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null"; ($error_code2, $cmd_output) = execute_system_cmd ($command_string); if ($error_code2 != 0) { $msg = "call failure for " . $command_string; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } else { $msg = "executed command_string = " . $command_string; gp_message ("debug", $subr_name, $msg); $msg = "cmd_output = " . $cmd_output; gp_message ("debug", $subr_name, $msg); } } else { $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 =~ /$load_long_regex/) { $Offset = $1; $VirtAddr = $2; $PhysAddr = $3; $FileSiz = $4; $MemSiz = $5; $Flg = $6; $Align = $7; $elf_offset = $VirtAddr; $msg = "single line version elf_offset = " . $elf_offset; gp_message ("debug", $subr_name, $msg); return ($elf_offset); } elsif ($foo =~ /$load_short_regex/) { #------------------------------------------------------------------------------ # is it a two line version? #------------------------------------------------------------------------------ $Offset = $1; $VirtAddr = $2; # maybe $PhysAddr = $3; if ($i != $#foo) { $foo1 = $foo[$i + 1]; chomp ($foo1); if ($foo1 =~ /$re_regex/) { $FileSiz = $1; $MemSiz = $2; $Flg = $3; $Align = $4; $elf_offset = $VirtAddr; $msg = "two line version elf_offset = " . $elf_offset; gp_message ("debug", $subr_name, $msg); 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) = @_; my $cmd_output; my $error_code; my $msg; chomp ($target_cmd); $cmd_output = qx ($target_cmd); $error_code = ${^CHILD_ERROR_NATIVE}; if ($error_code != 0) { chomp ($cmd_output); $msg = "failure executing command " . $target_cmd; gp_message ("error", $subr_name, $msg); $msg = "error code = " . $error_code; gp_message ("error", $subr_name, $msg); $msg = "cmd_output = " . $cmd_output; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } else { $msg = "executed command " . $target_cmd; gp_message ("debugXL", $subr_name, $msg); } 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 $map_xml_regex; $map_xml_regex = '<event kind="map"\s.*'; $map_xml_regex .= 'vaddr="0x([0-9a-fA-F]+)"\s+.*'; $map_xml_regex .= 'foffset="\+*0x([0-9a-fA-F]+)"\s.*'; $map_xml_regex .= 'modes="0x([0-9]+)"\s.*'; $map_xml_regex .= 'name="(.*)".*>$'; my $extracted_information; my $input_line; my $vaddr; my $foffset; my $msg; my $modes; my $name_path; my $name; my $full_path_exec; my $executable_name; my $result_VA; my $va_executable_in_hex; $msg = " - unable to open file $input_map_xml_file for reading:"; open (MAP_XML, "<", $input_map_xml_file) or die ($subr_name . $msg . " " . $!); $msg = "opened file $input_map_xml_file for reading"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Scan the file. We need to find the name of the executable with the mode set # to 0x005. For this entry we have to capture the name, the mode, the virtual # address and the offset. #------------------------------------------------------------------------------ $extracted_information = $FALSE; while (<MAP_XML>) { $input_line = $_; chomp ($input_line); $msg = "read input_line = $input_line"; gp_message ("debug", $subr_name, $msg); if ($input_line =~ /^$map_xml_regex/) { $msg = "target line = $input_line"; gp_message ("debug", $subr_name, $msg); $vaddr = $1; $foffset = $2; $modes = $3; $name_path = $4; $name = get_basename ($name_path); $msg = "extracted vaddr = $vaddr foffset = $foffset"; $msg .= " modes = $modes"; gp_message ("debug", $subr_name, $msg); $msg = "extracted name_path = $name_path name = $name"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # The base virtual address is calculated as vaddr-foffset. Although Perl # 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; $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; $msg = "result_VA = $result_VA"; gp_message ("debug", $subr_name, $msg); $msg = "va_executable_in_hex = $va_executable_in_hex"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Stop reading when we found the correct entry. #------------------------------------------------------------------------------ if ($modes eq "005") { $extracted_information = $TRUE; last; } } } #-- End of while-loop if (not $extracted_information) { $msg = "cannot find the necessary information in file"; $msg .= " " . $input_map_xml_file; gp_message ("assertion", $subr_name, $msg); } $msg = "full_path_exec = $full_path_exec"; gp_message ("debug", $subr_name, $msg); $msg = "executable_name = $executable_name"; gp_message ("debug", $subr_name, $msg); $msg = "va_executable_in_hex = $va_executable_in_hex"; gp_message ("debug", $subr_name, $msg); return ($full_path_exec, $executable_name, $va_executable_in_hex); } #-- End of subroutine extract_info_from_map_xml #------------------------------------------------------------------------------ # This routine analyzes the metric line and extracts the metric specifics # 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 #------------------------------------------------------------------------------ # Extract the option value(s) from the input array. In case the number of # values execeeds the specified limit, warning messages are printed. # # In case the option value is valid, g_user_settings is updated with this # value and a value of TRUE is returned. Otherwise the return value is FALSE. # # Note that not in all invocations of this subroutine, gp_message() is # operational. Only after the debug settings have been finalized, the # messages are printed. # # This subroutine also generates warnings about multiple occurrences # and the validity of the values. #------------------------------------------------------------------------------ sub extract_option_value { my $subr_name = get_my_name (); my ($option_dir_ref, $max_occurrences_ref, $internal_option_name_ref, $option_name_ref) = @_; my @option_dir = @{ $option_dir_ref }; my $max_occurrences = ${ $max_occurrences_ref }; my $internal_option_name = ${ $internal_option_name_ref }; my $option_name = ${ $option_name_ref }; my $deprecated_option_used; my $excess_occurrences; my $msg; my $no_of_occurrences; my $no_of_warnings = 0; my $option_value = "not set yet"; my $option_value_missing; my $option_value_missing_ref; my $reset_blank_value; my $special_treatment = $FALSE; my $valid = $FALSE; my $valid_ref; if (@option_dir) { $no_of_occurrences = scalar (@option_dir); $msg = "option_name = $option_name"; gp_message ("debug", $subr_name, $msg); $msg = "internal_option_name = $internal_option_name"; gp_message ("debug", $subr_name, $msg); $msg = "no_of_occurrences = $no_of_occurrences"; gp_message ("debug", $subr_name, $msg); $excess_occurrences = ($no_of_occurrences > $max_occurrences) ? $TRUE : $FALSE; #------------------------------------------------------------------------------ # This is not supposed to happen, but just to be sure, there is a check. #------------------------------------------------------------------------------ if ($no_of_occurrences < 1) { $msg = "the number of fields is $no_of_occurrences"; $msg .= " - should at least be 1"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # For backward compatibility, we support the legacy "on" and "off" values for # certain options. # # We also support the debug option without value. In case no value is given, # it is set to "on". # # Note that regardless of the value(s) in ARGV, internally we use the on/off # setting. #------------------------------------------------------------------------------ if (($g_user_settings{$internal_option_name}{"data_type"} eq "onoff") or ($internal_option_name eq "debug")) { $msg = "enable special treatment of the option"; gp_message ("debug", $subr_name, $msg); $special_treatment = $TRUE; } #------------------------------------------------------------------------------ # Issue a warning if the same option occcurs more often than what is supported. #------------------------------------------------------------------------------ if ($excess_occurrences) { $msg = "multiple occurrences of the " . $option_name . " option found:"; gp_message ("debugM", $subr_name, $msg); gp_message ("warning", $subr_name, $g_html_new_line . $msg); } #------------------------------------------------------------------------------ # Main loop over all the occurrences of the options. This is a rather simple # approach since only the last value seen will be accepted. # # To assist the user with troubleshooting, the values that are ignored will be # checked for validity and a marker to this extent will be printed. # # NOTE: # If an option may have multiple meaningful occurrences, this part needs to be # revisited. #------------------------------------------------------------------------------ $deprecated_option_used = $FALSE; for my $key (keys @option_dir) { $option_value = $option_dir[$key]; $reset_blank_value = $FALSE; #------------------------------------------------------------------------------ # For the "onoff" options, convert a blank value to "on". #------------------------------------------------------------------------------ if (($option_value eq "on") or ($option_value eq "off")) { if (($option_name eq "--verbose") or ($option_name eq "--quiet")) { $deprecated_option_used = $TRUE; } } #------------------------------------------------------------------------------ # For the "onoff" options, convert a blank value to "on". #------------------------------------------------------------------------------ if ($special_treatment and ($option_value eq "")) { $option_value = "on"; $reset_blank_value = $TRUE; $msg = "reset option value for $option_name from blank"; $msg .= " to \"on\""; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check for the option value to be valid. It may also happen that an option # does not have a value, while it should have one. #------------------------------------------------------------------------------ ($valid_ref, $option_value_missing_ref) = check_and_set_user_option ( $internal_option_name, $option_value); $valid = ${ $valid_ref }; $option_value_missing = ${ $option_value_missing_ref }; $msg = "option_value = $option_value"; gp_message ("debug", $subr_name, $msg); $msg = "after check_and_set_user_option: valid = $valid"; $msg .= " option_value_missing = $option_value_missing"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Generate warning messages, but if an option value is missing, it will also # be considered to be a fatal error. #------------------------------------------------------------------------------ if ($excess_occurrences) { if ($option_value_missing) { $msg = "$option_name option - missing a value"; } else { #------------------------------------------------------------------------------ # A little trick to avoid user confusion. Although we have set the internal # value to "on", the user did not set this and so we print "" instead. #------------------------------------------------------------------------------ if ($reset_blank_value) { $msg = "$option_name option - value = \"\""; } else { $msg = "$option_name option - value = $option_value"; } $msg .= ($valid) ? " (valid value)" : " (invalid value)"; } gp_message ("debug", $subr_name, $msg); gp_message ("warning", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check for the last occurrence of the option to be valid. If it is not, it # is a fatal error. #------------------------------------------------------------------------------ if ((not $valid) && ($key == $no_of_occurrences-1)) { if ($option_value_missing) { $msg = "the $option_name option requires a value"; } else { $msg = "the value of $option_value for the $option_name"; $msg .= " option is invalid"; } gp_message ("debug", $subr_name, $g_error_keyword . $msg); gp_message ("error", $subr_name, $msg); $g_total_error_count++; } } #------------------------------------------------------------------------------ # Issue a warning if the same option occcurs more often than what is supported # and warn the user that all but the last value will be ignored. #------------------------------------------------------------------------------ if ($excess_occurrences) { $msg = "all values but the last one shown above are ignored"; gp_message ("debugM", $subr_name, $msg); gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; } } #------------------------------------------------------------------------------ # Issue a warning if the old on/off syntax is used still. #------------------------------------------------------------------------------ if ($deprecated_option_used) { $msg = "<br>"; $msg .= "the on/off syntax for option $option_name has been"; $msg .= " deprecated"; gp_message ("warning", $subr_name, $msg); $msg = "this option acts like a switch now"; gp_message ("warning", $subr_name, $msg); $msg = "support for the old syntax may be terminated"; $msg .= " in a future update"; gp_message ("warning", $subr_name, $msg); $msg = "please check the man page of gp-display-html"; $msg .= " for more details"; gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; } return (\$valid); } #-- End of subroutine extract_option_value #------------------------------------------------------------------------------ # TBD #------------------------------------------------------------------------------ sub extract_source_line_number { 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 #------------------------------------------------------------------------------ # Finalize the settings for the special options verbose, debug, warnings and # quiet. #------------------------------------------------------------------------------ sub finalize_special_options { my $subr_name = get_my_name (); my $msg; #------------------------------------------------------------------------------ # If quiet mode has been enabled, disable verbose, warnings and debug. #------------------------------------------------------------------------------ if ($g_quiet) { $g_user_settings{"verbose"}{"current_value"} = "off"; $g_user_settings{"nowarnings"}{"current_value"} = "on"; $g_user_settings{"warnings"}{"current_value"} = "off"; $g_user_settings{"debug"}{"current_value"} = "off"; $g_debug = $FALSE; $g_verbose = $FALSE; $g_warnings = $FALSE; my $debug_off = "off"; my $ignore_value = set_debug_size (\$debug_off); } else { #------------------------------------------------------------------------------ # Disable output buffering if verbose, debug, and/or warnings are enabled. #------------------------------------------------------------------------------ if ($g_verbose or $g_debug or $g_warnings) { STDOUT->autoflush (1); $msg = "enabled autoflush for STDOUT"; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # If verbose and/or debug have been enabled, print a message. #------------------------------------------------------------------------------ ## gp_message ("verbose", $subr_name, "verbose mode has been enabled"); ## gp_message ("debug", $subr_name, "debug " . $g_debug_size_value . " mode has been enabled"); } return (0); } #-- End of subroutine finalize_special_options #------------------------------------------------------------------------------ # For a give routine name and address, find the index into the # function_info array #------------------------------------------------------------------------------ sub find_index_in_function_info { 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, \$gp_path, \$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); $line =~ s/ -- no functions found//; 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 $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 $caller_callee_data_ref; 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 $msg; my $remainder2; 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"); $msg = "building caller-callee file " . $outfile; gp_message ("debug", $subr_name, $msg); gp_message ("verbose", $subr_name, $msg); #------------------------------------------------------------------------------ # 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 an array with the name caller_callee_data. #------------------------------------------------------------------------------ chomp (@caller_callee_data = <CALLER_CALLEE_IN>); #------------------------------------------------------------------------------ # Remove a legacy redundant string, if any. #------------------------------------------------------------------------------ @caller_callee_data = @{ remove_redundant_string (\@caller_callee_data)}; #------------------------------------------------------------------------------ # 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. #------------------------------------------------------------------------------ $g_max_length_first_metric = 0; my @hex_addresses = (); my @metrics_array = (); my @length_first_metric = (); my @special_marker = (); my @the_function_name = (); my @the_metrics = (); my $find_hex_address_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(.*)'; my $find_metric_values_regex = '\)\s+\[.*\]\s+(\d+'; $find_metric_values_regex .= '[\.\d\ ]*)|\)\s+(\d+[\.\d\ ]*)'; my $find_marker_regex = '(^\*).*'; my @html_block_prologue; my @html_code_function_block; my $marker; my $list_with_metrics; my $reduced_line; $msg = "loop over the caller-callee data - number of lines = "; $msg .= ($#caller_callee_data + 1); gp_message ("debugXL", $subr_name, $msg); for (my $line = 0; $line <= $#caller_callee_data; $line++) { $input_line = $caller_callee_data[$line]; $reduced_line = $input_line; $msg = "line = " . $line . " input_line = " . $input_line; gp_message ("debugXL", $subr_name, $msg); if ($input_line =~ /$find_hex_address_regex/) #------------------------------------------------------------------------------ # This is an input line of interest. #------------------------------------------------------------------------------ { my ($hex_address_ref, $marker_ref, $reduced_line_ref, $list_with_metrics_ref) = split_function_data_line (\$input_line); $hex_address = ${ $hex_address_ref }; $marker = ${ $marker_ref }; $reduced_line = ${ $reduced_line_ref }; $list_with_metrics = ${ $list_with_metrics_ref }; $msg = "RESULT full_hex_address = " . $hex_address; $msg .= " -- metric values = " . $list_with_metrics; $msg .= " -- marker = " . $marker; $msg .= " -- function name = " . $reduced_line; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Store the address and marker. #------------------------------------------------------------------------------ push (@the_function_name, $reduced_line); push (@hex_addresses, $hex_address); if ($marker eq "*") { push (@special_marker, "*"); } else { push (@special_marker, "X"); } #------------------------------------------------------------------------------ # Processing of the metrics. #------------------------------------------------------------------------------ @metrics_array = split (" ", $list_with_metrics); #------------------------------------------------------------------------------ # 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 = $metrics_array[0]; $msg = "first metric found = " . $first_metric; gp_message ("debugXL", $subr_name, $msg); if ($first_metric =~ /^0$decimal_separator$/) { $first_metric = "0.ZZZ"; $msg = "fixed up $first_metric"; gp_message ("debugXL", $subr_name, $msg); } $g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric)); $msg = "first_metric = $first_metric " . "g_max_length_first_metric = $g_max_length_first_metric"; gp_message ("debugXL", $subr_name, $msg); push (@length_first_metric, length ($first_metric)); push (@the_metrics, $list_with_metrics); } } $msg = "the following function names have been found"; gp_message ("debugM", $subr_name, $msg); for my $i (0 .. $#the_function_name) { $msg = "the_function_name{" . $i . "] = " . $the_function_name[$i]; gp_message ("debugM", $subr_name, $msg); } $msg = "final: g_max_length_first_metric = " . $g_max_length_first_metric; gp_message ("debugM", $subr_name, $msg); $msg = "\$#hex_addresses = " . $#hex_addresses; gp_message ("debugM", $subr_name, $msg); #------------------------------------------------------------------------------ # 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++) { $input_line = $caller_callee_data[$line]; if ($input_line =~ /$header_name_regex/) { $scan_header = $TRUE; $msg = "line = " . $line . " encountered start of the header"; $msg .= " scan_header = " . $scan_header . " first = " . $first; gp_message ("debugXL", $subr_name, $msg); } elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/)) { $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; $msg = "line = $line updated index_end = $index_end"; gp_message ("debugXL", $subr_name, $msg); $msg = "line = $line input_line = " . $input_line; gp_message ("debugXL", $subr_name, $msg); $msg = "line = $line data_function_block = " . $data_function_block; 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; $msg = "new block"; gp_message ("debugXL", $subr_name, $msg); $msg = "line = " . $line . " index_start = " . $index_start; gp_message ("debugXL", $subr_name, $msg); $msg = "line = " . $line . " index_end = " . $index_end; gp_message ("debugXL", $subr_name, $msg); $msg = "line = " . $line . " data_function_block = "; $msg .= $data_function_block; gp_message ("debugXL", $subr_name, $msg); push (@function_blocks, $data_function_block); ## $msg = " generating the html blocks ("; ## $msg .= $index_start . " - " . $index_end .")"; ## gp_message ("verbose", $subr_name, $msg); 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); @html_block_prologue = @{ $html_block_prologue_ref }; @html_code_function_block = @{ $html_code_function_block_ref }; for my $lines (0 .. $#html_code_function_block) { $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; $msg = "line = " . $line . " reset index_start = " . $index_start; gp_message ("debugXL", $subr_name, $msg); $msg = "line = " . $line . " reset index_end = " . $index_end; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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. #------------------------------------------------------------------------------ $msg = "Parse and process function blocks - total blocks = "; $msg .= $#function_blocks + 1; gp_message ("verbose", $subr_name, $msg); for my $i (0 .. $#function_blocks) { $msg = "process function block " . $i; gp_message ("debugXL", $subr_name, $msg); $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i]; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # This split produces an empty first field. This is why we skip this in the # loop below. #------------------------------------------------------------------------------ my @entries = split ($separator, $function_blocks[$i]); #------------------------------------------------------------------------------ # An example of the content of array @entries: # <empty line> # 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]; $msg = "input_line = entries[" . $k . "] = ". $entries[$k]; gp_message ("debugXL", $subr_name, $msg); my ($hex_address_ref, $marker_ref, $reduced_line_ref, $list_with_metrics_ref) = split_function_data_line (\$input_line); $full_hex_address = ${ $hex_address_ref }; $marker_target_function = ${ $marker_ref }; $routine = ${ $reduced_line_ref }; $all_metrics = ${ $list_with_metrics_ref }; $msg = "RESULT full_hex_address = " . $full_hex_address; $msg .= " -- metric values = " . $all_metrics; $msg .= " -- marker = " . $marker_target_function; $msg .= " -- function name = " . $routine; gp_message ("debugXL", $subr_name, $msg); $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); push (@address_field, $full_hex_address); $msg = "pushed " . $full_hex_address; $msg .= " to array address_field"; gp_message ("debugXL", $subr_name, $msg); $modified_line = $all_metrics . " " . $routine; gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); push (@metric_values, $all_metrics); $msg = "pushed " . $all_metrics . " to array metric_values"; gp_message ("debugXL", $subr_name, $msg); push (@function_names, $routine); $msg = "pushed " . $routine . " to array function_names"; gp_message ("debugXL", $subr_name, $msg); } $total_header_lines = $#header_lines + 1; $msg = "total_header_lines = " . $total_header_lines; gp_message ("debugXL", $subr_name, $msg); 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) { $msg = $metric_values[$i] . " " . $marker[$i]; $msg .= $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. #------------------------------------------------------------------------------ $msg = "check for multiple occurrences - function_names = "; $msg .= ($#function_names + 1); gp_message ("debugXL", $subr_name, $msg); for my $i (0 .. $#function_names) { my $current_address = $address_field[$i]; my $found_a_match; my $ref_index; my $alt_name; my $addr_offset; $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; $msg = $routine . ": occurrences = "; $msg .= $g_function_occurrences{$routine}; gp_message ("debugXL", $subr_name, $msg); for my $ref (keys @{ $g_map_function_to_index{$routine} }) { $ref_index = $g_map_function_to_index{$routine}[$ref]; $msg = $routine . ": retrieving duplicate entry at "; $msg .= "ref_index = " . $ref_index; gp_message ("debugXL", $subr_name, $msg); $msg = $routine . ": function_info[" . $ref_index; $msg .= "]{alt_name} = "; $msg .= $function_info[$ref_index]{'alt_name'}; gp_message ("debugXL", $subr_name, $msg); $addr_offset = $function_info[$ref_index]{"addressobjtext"}; $msg = $routine . ": addr_offset = " . $addr_offset; gp_message ("debugXL", $subr_name, $msg); $addr_offset =~ s/$get_addr_offset_regex//; $msg = $routine . ": addr_offset = " . $addr_offset; gp_message ("debugXL", $subr_name, $msg); if ($addr_offset eq $current_address) { $found_a_match = $TRUE; last; } } $msg = $function_info[$ref_index]{'alt_name'}; $msg .= " is the actual function for i = " . $i . " "; $msg .= $found_a_match; gp_message ("debugXL", $subr_name, $msg); $alt_name = $function_info[$ref_index]{'alt_name'}; } gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); } $msg = "completed the check for multiple occurrences"; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # 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) { $msg = "i = " . $i . " " . $word_index_values[$i][0] . " "; $msg .= $word_index_values[$i][1]; gp_message ("debugXL", $subr_name, $msg); } #------------------------------------------------------------------------------ # Empty the buffers before processing the next block with data. #------------------------------------------------------------------------------ @function_names = (); @metric_values = (); @address_field = (); @marker = (); $msg = "erased contents of arrays function_names, metric_values, "; $msg .= "address_field, and marker"; gp_message ("debugXL", $subr_name, $msg); } 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); $msg = "the caller-callee information has been generated"; gp_message ("verbose", $subr_name, $msg); return (0); } #-- End of subroutine generate_caller_callee #------------------------------------------------------------------------------ # Generate the html version of the disassembly file. # # Note to self (TBD) # https://community.intel.com/t5/Intel-oneAPI-AI-Analytics/bd-p/ai-analytics-toolkit #------------------------------------------------------------------------------ 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 $file_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 #------------------------------------------------------------------------------ $file_is_empty = is_file_empty ($filename); if ($file_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"; $threshold_line .= " (--highlight-percentage) option:"; $threshold_line .= " " . $rounded_percentage . " (%)</i>"; } else { $threshold_line = "<i>The highlight percentage feature has not been"; $threshold_line .= " 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 $msg; 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. # TBD: Is still needed? Also, add the header command. #------------------------------------------------------------------------------ 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", $subr_name, "execution terminated"); } #------------------------------------------------------------------------------ # Parse the full function view and store the data. #------------------------------------------------------------------------------ my @input_data = (); my $empty_line_regex = '^\s*$'; ## my $full_function_view = $outputdir . "functions.full"; open (ALL_FUNC_DATA, "<", $full_function_view) 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]; $input_line =~ s/ -- no functions found//; $input_data[$line] =~ s/ -- no functions found//; $msg = "line = " . $line . " input_line = " . $input_line; gp_message ("debugXL", $subr_name, $msg); # 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 #------------------------------------------------------------------------------ # 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 $msg; 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 { $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"; $msg = "executing $GP_DISPLAY_TEXT to get the experiment details"; gp_message ("debug", $subr_name, $msg); $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); if ($error_code != 0) #------------------------------------------------------------------------------ # This is unlikely to happen, but you never know. #------------------------------------------------------------------------------ { $ignore_value = msg_display_text_failure ($gp_display_text_cmd, $error_code, $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 = (); my $msg; # TBD: check my $full_address_field; my %source_files = (); my $i; my $line; my $routine_flag; my $value; my $field; my $df_flag; my $address_decimal; my $routine; my $num_source_files = 0; my $number_of_unique_functions = 0; my $number_of_non_unique_functions = 0; my $function_info_regex = '\s*(\S+[a-zA-Z\s]*):(.*)'; my $get_hex_address_regex = '(\d+):(0x\S+)'; #------------------------------------------------------------------------------ # Open the file generated using the -fsummary option. #------------------------------------------------------------------------------ $msg = " - unable to open file $FSUMMARY_FILE for reading:"; open (FSUMMARY_FILE, "<", $FSUMMARY_FILE) or die ($subr_name . $msg . " " . $!); $msg = "opened file $FSUMMARY_FILE for reading"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # 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); #------------------------------------------------------------------------------ # Legacy issue to deal with. Up until somewhere between binutils 2.40 and 2.41, # gprofng display text might print the " -- no functions found" comment. # No, the two spaces after -- are not my typo ;-) # # Since then, this comment is no longer printed, but the safe approach is to # remove any occurrence upfront. #------------------------------------------------------------------------------ $line =~ s/ -- no functions found//; $msg = "line = " . $line; gp_message ("debugXL", $subr_name, $msg); 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. # # REVISIT This may not be needed anymore #------------------------------------------------------------------------------ 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; } $msg = "g_function_occurrences{$routine} = "; $msg .= $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; } #------------------------------------------------------------------------------ # Example format of an input block, where $line is one of the following: # Exclusive Total CPU Time: 0.001 ( 0.0%) # Inclusive Total CPU Time: 0.001 ( 0.0%) # Size: 92 # PC Address: 5:0x00125de0 # Source File: (unknown) # Object File: (unknown) # Load Object: /usr/lib64/libc-2.28.so # Mangled Name: # Aliases: __brk #------------------------------------------------------------------------------ $line =~ s/^\s+//; if ($line =~ /$function_info_regex/) { if (defined ($1) and defined($2)) { $field = $1; $value = $2; $value =~ s/$g_rm_surrounding_spaces_regex//g; $msg = "initial - field = " . $field . " value = " . $value; gp_message ("debugM", $subr_name, $msg); } else { $msg = "the input line pattern was not recognized"; gp_message ("warning", $subr_name, $msg); gp_message ("debug", $subr_name, $msg); $msg = "execution continues, but there may be a problem later"; gp_message ("warning", $subr_name, $msg); gp_message ("debug", $subr_name, $msg); $field = "not recognized"; $value = "not recognized"; } #------------------------------------------------------------------------------ # The field has no value. #------------------------------------------------------------------------------ if (length ($value) eq 0) ## if ($value =~ /^\s+$/) ## if (length ($2) gt 0) ## if ($2 == " ") { if ($field eq "Mangled Name") { $value = $routine; $msg = "no mangled name found - use the routine name "; $msg .= $routine . " as the mangled name"; gp_message ("debugM", $subr_name, $msg); } else { $value = "no_value_given"; $msg = "no value was found for this field - set to "; $msg .= $value; gp_message ("debugM", $subr_name, $msg); } } #------------------------------------------------------------------------------ # Remove any leading whitespace characters. #------------------------------------------------------------------------------ $value =~ s/$white_space_regex//; #------------------------------------------------------------------------------ # These are the final values that will be used. #------------------------------------------------------------------------------ $msg = "final - field = " . $field . " value = " . $value; gp_message ("debugM", $subr_name, $msg); $function_info[$i]{$field} = $value; } ## $value =~ s/$white_space_regex//; ## \s*(\S+[a-zA-Z\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) #------------------------------------------------------------------------------ # No value #------------------------------------------------------------------------------ ### { ### $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) ### { ### $whatever = $input_fields[0]; ### if ($whatever eq "PC Address") ### #------------------------------------------------------------------------------ ### # Must be an address field. Restore the second colon. ### #------------------------------------------------------------------------------ ### { ### $value = $input_fields[1] . ":" . $input_fields[2]; ### } ### elsif ($whatever eq "Mangled Name") ### #------------------------------------------------------------------------------ ### # The mangled name includes a colon (:). Just copy the entire string. ### #------------------------------------------------------------------------------ ### { ### $value = $input_fields[2]; ### } ### } ### else ### { ### if ($whatever eq "Aliases") ### #------------------------------------------------------------------------------ ### # The mangled name includes a colon (:). Just copy the entire string. ### #------------------------------------------------------------------------------ ### { ### $value = $input_fields[2]; ### } ### else ### { ### $msg = "input line = " . $line; ### gp_message ("debug", $subr_name, $msg); ### for my $i (keys @input_fields) ### { ### $msg = "input_fields[$i] = " . $input_fields[$i]; ### gp_message ("debug", $subr_name, $msg); ### } ### $msg = "unexpected input: number of fields = " . $no_of_elements; ### gp_message ("debug", $subr_name, $msg); ### ## gp_message ("assertion", $subr_name, $msg); ### } ### } ## $function_info[$i]{$field} = $value; #------------------------------------------------------------------------------ # TBD: Seems to be not used anymore and can most likely be removed. Check this. #------------------------------------------------------------------------------ if ($field =~ /Source File/) { if (!exists ($source_files{$value})) { $source_files{$value} = $TRUE; $num_source_files++; } } if ($field =~ /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. # For example @2:0x0003f280 #------------------------------------------------------------------------------ $full_address_field = $segment.":0x".$offset; $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; $msg = "function_address_and_index{$routine}{$value} = "; $msg .= $function_address_and_index{$routine}{$value}; gp_message ("debugXL", $subr_name, $msg); } else { $msg = "function_info: $FSUMMARY_FILE: function $routine"; $msg .= " already has a PC Address"; gp_message ("debugXL", $subr_name, $msg); } $g_total_function_count++; } } 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 =~ /$get_hex_address_regex/) { $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 = List::Util::max ($max_function_length, $function_info[$i]{"function length"}); gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"}); } #------------------------------------------------------------------------------ # 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"}; } $msg = "target_function = $target_function html_line = $html_line"; gp_message ("debugM", $subr_name, $msg); $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) { $msg = "html_source_functions{$i} = $html_source_functions{$i}"; gp_message ("debugM", $subr_name, $msg); } for my $i (keys @function_info) { $msg = "function_info[$i]{\"html function block\"} = "; $msg .= $function_info[$i]{"html function block"}; gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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] }) { $msg = "on return: function_info[$i]{$role} = "; $msg .= $function_info[$i]{$role}; gp_message ("debugM", $subr_name, $msg); } } #------------------------------------------------------------------------------ # 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} }) { $msg = "on return: function_address_and_index{$F}{$fields} = "; $msg .= $function_address_and_index{$F}{$fields}; gp_message ("debugM", $subr_name, $msg); } } #------------------------------------------------------------------------------ # 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 this info on the page with experiment data. Include names # with multiple occurrences. #------------------------------------------------------------------------------ $msg = "Number of source files : " . $num_source_files; gp_message ("debug", $subr_name, $msg); $msg = "Total number of functions : " . $g_total_function_count; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions with a unique name : " . $number_of_unique_functions; gp_message ("debug", $subr_name, $msg); $msg = "Number of functions with more than one occurrence : " . $number_of_non_unique_functions; gp_message ("debug", $subr_name, $msg); my $multi_occurrences = $g_total_function_count - $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 }; my $alt_name = $routine; my $current_address = $hex_address; my $found_a_match; my $index_into_function_info; my $msg; my $target_tag; #------------------------------------------------------------------------------ # Check if this function has multiple occurrences. #------------------------------------------------------------------------------ $msg = "check for multiple occurrences"; gp_message ("debugM", $subr_name, $msg); $msg = "target routine name = " . $routine; gp_message ("debugM", $subr_name, $msg); 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); ## KANWEG for my $key (sort keys %g_map_function_to_index) ## KANWEG { ## KANWEG $msg = "g_map_function_to_index{". $key . "} = " . $g_map_function_to_index{$key}; ## KANWEG gp_message ("debugXL", $subr_name, $msg); ## KANWEG } 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 $error_code; my $hostname_current; my $ignore_output; my $msg; my $target_cmd; #------------------------------------------------------------------------------ # 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) { $msg = "the $machine instruction set architecture is not supported"; gp_message ("error", $subr_name, $msg); gp_message ("diag", $subr_name, "Error: " . $msg); $msg = "temporarily ignored for development purposes"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; exit (0); } #------------------------------------------------------------------------------ # 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 $ignore_value; 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 (not $g_debug)) { $trigger_debug = $FALSE; } #------------------------------------------------------------------------------ # Unconditionally buffer all warning messages. These are available through the # index.html page and cannot be disabled. # # If the quiet mode has been enabled, warnings are not printed though. #------------------------------------------------------------------------------ if ($action eq "warning") { #------------------------------------------------------------------------------ # Remove any leading <br>, capitalize the first letter, and put the <br> back # before storing the message in the buffer. #------------------------------------------------------------------------------ if ($comment_line =~ /^$g_html_new_line/) { $msg = $comment_line; $msg =~ s/$g_html_new_line//; $comment_line = $g_html_new_line . ucfirst ($msg); push (@g_warning_msgs, $comment_line); } else { push (@g_warning_msgs, ucfirst ($comment_line)); } } #------------------------------------------------------------------------------ # Unconditionally buffer all errror messages. These will be printed prior to # terminate execution. #------------------------------------------------------------------------------ if ($action eq "error") #------------------------------------------------------------------------------ # Remove any leading <br>, capitalize the first letter, and put the <br> back. #------------------------------------------------------------------------------ { if ($comment_line =~ /^$g_html_new_line/) { $msg = $comment_line; $msg =~ s/$g_html_new_line//; $comment_line = $g_html_new_line . ucfirst ($msg); push (@g_error_msgs, $comment_line); } else { push (@g_error_msgs, ucfirst ($comment_line)); } } #------------------------------------------------------------------------------ # Quick return in several cases. Note that "debug", "verbose", "warning", and # "diag" messages are suppressed in quiet mode, but "error", "abort" and # "assertion" always pass. #------------------------------------------------------------------------------ if (( ($action eq "verbose") and (not $g_verbose)) or (($action eq "debug") and (not $trigger_debug)) or (($action eq "verbose") and ($g_quiet)) or (($action eq "debug") and ($g_quiet)) or (($action eq "warning") and ($g_quiet)) or (($action eq "diag") and ($g_quiet))) { return (0); } #------------------------------------------------------------------------------ # In diag mode, just print the input line and nothing else. #------------------------------------------------------------------------------ if (( $action eq "debug") or ($action eq "abort") 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")) if ($action eq "abort") #------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. Since these are # user errors, the name of the routine is not shown. The same for "abort". # If you want to display the routine name too, use an assertion. #------------------------------------------------------------------------------ { my $error_identifier = $supported_identifiers{"error"}; if (@g_error_msgs) { $ignore_value = print_errors_buffer (\$error_identifier); } printf ("%-9s %s", $identifier, ucfirst ($comment_line)); printf (" - %s\n", "execution is terminated"); } elsif ($action eq "assertion") #------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. #------------------------------------------------------------------------------ { #------------------------------------------------------------------------------ # The lines are too long, but breaking the argument list gives this warning: # printf (...) interpreted as function #------------------------------------------------------------------------------ printf ("%-17s %-30s", $identifier, $fixed_size_name); printf (" - %s\n", $comment_line); } elsif (($action eq "debug") and ($trigger_debug)) #------------------------------------------------------------------------------ # Debug messages are printed "as is". Avoids issues when searching for them ;-) #------------------------------------------------------------------------------ { printf ("%-9s %-30s", $identifier, $fixed_size_name); printf (" - %s\n", $comment_line); } else #------------------------------------------------------------------------------ # Enforce that the message starts with a lowercase symbol. #------------------------------------------------------------------------------ { printf ("%-9s %-30s", $identifier, $fixed_size_name); printf (" - %s\n", $comment_line); } } elsif ($action eq "verbose") #------------------------------------------------------------------------------ # The first character in the verbose message is capatilized. #------------------------------------------------------------------------------ { printf ("%s\n", ucfirst ($comment_line)); } elsif ($action eq "diag") #------------------------------------------------------------------------------ # The diag messages are meant to be diagnostics. Only the comment line is # printed. #------------------------------------------------------------------------------ { printf ("%s\n", $comment_line); return (0); } #------------------------------------------------------------------------------ # Terminate execution in case the identifier is "abort". #------------------------------------------------------------------------------ if (($action eq "abort") or ($action eq "assertion")) { ## print "ABORT temporarily disabled for testing purposes\n"; exit (-1); } else { return (0); } } #-- End of subroutine gp_message #------------------------------------------------------------------------------ # 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 html_create_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"); #------------------------------------------------------------------------------ # 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 ($g_total_warning_count > 0) { print WARNINGS_OUT "<pre>\n"; print WARNINGS_OUT "$_\n" for @g_warning_msgs; print WARNINGS_OUT "</pre>\n"; } else { print WARNINGS_OUT $msg_no_warnings; } print WARNINGS_OUT $html_home_left; print WARNINGS_OUT "<br>\n"; print WARNINGS_OUT $html_acknowledgement; print WARNINGS_OUT $html_end; close (WARNINGS_OUT); return (0); } #-- End of subroutine html_create_warnings_page #------------------------------------------------------------------------------ # Generate the HTML with the experiment summary. #------------------------------------------------------------------------------ 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 index.html file. #------------------------------------------------------------------------------ sub html_generate_index { my $subr_name = get_my_name (); my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, $metric_description_reversed_ref, $table_execution_stats_ref) = @_; my $outputdir = ${ $outputdir_ref }; my $html_first_metric_file = ${ $html_first_metric_file_ref }; my $summary_metrics = ${ $summary_metrics_ref }; my $number_of_metrics = ${ $number_of_metrics_ref }; my @function_info = @{ $function_info_ref }; my %function_address_info = %{ $function_address_info_ref }; my @sort_fields = @{ $sort_fields_ref }; my @exp_dir_list = @{ $exp_dir_list_ref }; my %addressobjtextm = %{ $addressobjtextm_ref }; my %metric_description_reversed = %{ $metric_description_reversed_ref }; my @table_execution_stats = @{ $table_execution_stats_ref }; my @file_contents = (); my $acknowledgement; my @abs_path_exp_dirs = (); my $input_experiments; my $target_function; my $html_line; my $ftag; my $max_length = 0; my %html_source_functions = (); my $html_header; my @experiment_directories = (); my $html_acknowledgement; my $html_file_title; my $html_output_file; my $html_function_view; my $html_caller_callee_view; my $html_experiment_info; my $html_warnings_page; my $href_link; my $file_title; my $html_gprofng; my $html_end; my $max_length_metrics; my $page_title; my $size_text; my $position_text; my $ln; my $base; my $base_index_page; my $infile; my $outfile; my $rec; my $skip; my $callsize; my $dest; my $final_string; my @headers; my $header; my $sort_index; my $pc_address; my $anchor; my $directory_name; my $f2; my $f3; my $file; my $sline; my $src; my $srcfile_name; my $tmp1; my $tmp2; my $fullsize; my $regf2; my $trimsize; my $EIL; my $EEIL; my $AOBJ; my $RI; my $HDR; my $CALLER_CALLEE; my $NAME; my $SRC; my $TRIMMED; #------------------------------------------------------------------------------ # Add a forward slash to make it easier when creating file names. #------------------------------------------------------------------------------ $outputdir = append_forward_slash ($outputdir); gp_message ("debug", $subr_name, "outputdir = $outputdir"); my $LANG = $g_locale_settings{"LANG"}; my $decimal_separator = $g_locale_settings{"decimal_separator"}; $input_experiments = join (", ", @exp_dir_list); for my $i (0 .. $#exp_dir_list) { my $dir = get_basename ($exp_dir_list[$i]); push @abs_path_exp_dirs, $dir; } $input_experiments = join (", ", @abs_path_exp_dirs); gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); #------------------------------------------------------------------------------ # TBD: Pass in the values for $expr_name and $cmd #------------------------------------------------------------------------------ $html_file_title = "Main index page"; @experiment_directories = split (",", $input_experiments); $html_acknowledgement = ${ create_html_credits () }; $html_end = ${ terminate_html_document () }; $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html"; open (INDEX, ">", $html_output_file) or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); $page_title = "GPROFNG Performance Analysis"; $size_text = "h1"; $position_text = "center"; $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; $html_header = ${ create_html_header (\$html_file_title) }; print INDEX $html_header; print INDEX $html_gprofng; print INDEX "$_" for @g_html_experiment_stats; print INDEX "$_" for @table_execution_stats; $html_experiment_info = "<a href=\'"; $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html"; $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n"; $html_warnings_page = "<a href=\'"; $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html"; $html_warnings_page .= "\'><h3>Warnings (" . $g_total_warning_count; $html_warnings_page .= ")</h3></a>\n"; $html_function_view = "<a href=\'"; $html_function_view .= $html_first_metric_file; $html_function_view .= "\'><h3>Function View</h3></a>\n"; $html_caller_callee_view = "<a href=\'"; $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html"; $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n"; print INDEX "<br>\n"; ## print INDEX "<b>\n"; print INDEX $html_experiment_info; print INDEX $html_warnings_page; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_function_view; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_caller_callee_view; ## print INDEX "</b>\n"; ## print INDEX "<br>\n"; ## print INDEX "<br>\n"; print INDEX $html_acknowledgement; print INDEX $html_end; close (INDEX); gp_message ("debug", $subr_name, "closed file $html_output_file"); return (0); } #-- End of subroutine html_generate_index #------------------------------------------------------------------------------ # Generate the entries for the tables with the experiment info. #------------------------------------------------------------------------------ sub html_generate_table_data { my $subr_name = get_my_name (); 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 $is_empty; my $file_stat; my $msg; my $size; 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. #------------------------------------------------------------------------------ $msg = "filename = $filename not found"; gp_message ("debug", $subr_name, $msg); $is_empty = $TRUE; } else { $file_stat = stat ($filename); $size = $file_stat->size; $is_empty = ($size == 0) ? $TRUE : $FALSE; } $msg = "filename = $filename size = $size is_empty = $is_empty"; gp_message ("debug", $subr_name, $msg); 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 #------------------------------------------------------------------------------ # Print a message after a failure in $GP_DISPLAY_TEXT. #------------------------------------------------------------------------------ sub msg_display_text_failure { my $subr_name = get_my_name (); my ($gp_display_text_cmd, $error_code, $error_file) = @_; my $msg; $msg = "error code = $error_code - failure executing the following command:"; gp_message ("error", $subr_name, $msg); gp_message ("error", $subr_name, $gp_display_text_cmd); $msg = "check file $error_file for more details"; gp_message ("error", $subr_name, $msg); return (0); } #-- End of subroutine msg_display_text_failure #------------------------------------------------------------------------------ # TBD. #------------------------------------------------------------------------------ sub name_regex { my $subr_name = get_my_name (); 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 more specific to the option, plus cross option checks, will be # performed soon after this subroutine has executed. # # Warnings, but also errors, are buffered. In this way we can collect as many # warnings and errors as possible, before bailing out in case of an error. #------------------------------------------------------------------------------ sub parse_and_check_user_options { my $subr_name = get_my_name (); my @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 $msg; my $outputdir_value; my $quiet_value; my $hp_value; my $valid; my $verbose_value; my $number_of_fields; my $internal_option_name; my $option_name; my $verbose = undef; my $warning = undef; my @opt_debug = (); my @opt_highlight_percentage = (); my @opt_nowarnings = (); my @opt_obsoleted_hp = (); my @opt_output = (); my @opt_overwrite = (); my @opt_quiet = (); my @opt_verbose = (); my @opt_warnings = (); #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ my $no_of_warnings; my $total_warning_msgs = 0; my $option_value; my $option_warnings; my $no_of_warnings_ref; my $no_of_errors_ref; my $index_exp; my $first = $TRUE; my $trigger = $FALSE; my $found_non_exp = $FALSE; my $name_non_exp_dir; my $no_of_experiments = 0; my @opt_help = (); my @opt_version = (); my $stop_execution = $FALSE; my $option_value_ref; my $max_occurrences; #------------------------------------------------------------------------------ # Configure Getopt to: # - Silence warnings, since these are handled by the code. # - Enforce case sensitivity in order to support -o and -O for example. #------------------------------------------------------------------------------ Getopt::Long::Configure("pass_through", "no_ignore_case"); #------------------------------------------------------------------------------ # Check for the --help and --version options. Print a message and exit. # Note that we support using both options simultaneously on the command line. #------------------------------------------------------------------------------ GetOptions ( "help" => \@opt_help, "version" => \@opt_version ); if (@opt_help) { $stop_execution = $TRUE; $ignore_value = print_help_info (); } if (@opt_version) { $stop_execution = $TRUE; $ignore_value = print_version_info (); } if ($stop_execution) { exit (0); } #------------------------------------------------------------------------------ # First, scan ARGV for the experiment names. If there are no names, or the # list with the names is not contiguous (meaning there is an non-experiment # name in this list), an error message is printed and execution is terminated. # # Upon return from this function, the list with the experiment names is # known and has been removed from ARGV. # # As a result, exp_dir_list is available from there on. # # This makes the subsequent processing of ARGV with GetOptions() easier. #------------------------------------------------------------------------------ @exp_dir_list = @{ check_the_experiment_list () }; #------------------------------------------------------------------------------ # Configure Getopt to: # - Silence warnings, since these are handled by the code. # - Enforce case sensitivity in order to support -o and -O for example. # - Allow unique abbreviations (also the default). #------------------------------------------------------------------------------ Getopt::Long::Configure("pass_through", "no_ignore_case", "auto_abbrev"); #------------------------------------------------------------------------------ # Get the remaining command line options. # # Recall: # = => option requires a value # : => option value is optional #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # All options are considered to be a string. # # We request every option supported to have an optional value. Otherwise, # GetOptions skips an option that does not have a value. # # The logic that parses the options deals with this and checks if an option # that should have a value, actually has one. #------------------------------------------------------------------------------ GetOptions ( "verbose|v:s" => \@opt_verbose, "debug|d:s" => \@opt_debug, "warnings|w:s" => \@opt_warnings, "nowarnings:s" => \@opt_nowarnings, "quiet|q:s" => \@opt_quiet, "output|o=s" => \@opt_output, "overwrite|O=s" => \@opt_overwrite, "highlight-percentage=s" => \@opt_highlight_percentage, "hp=s" => \@opt_obsoleted_hp ); #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Handle the user input and where needed, generate warnings. In a later stage # we check for (cross option) errors and warnings. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # The very first thing to do is to determine if the user has enabled one of the # following options and take action accordingly: # --quiet, --verbose, --debug, --warnings # # We first need to check for quiet mode to be set. If so, all messages need to # be silenced, regardless of the settings for verbose, debug, and warnings. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # The quiet option. #------------------------------------------------------------------------------ if (@opt_quiet) { $max_occurrences = 1; $internal_option_name = "quiet"; $option_name = "--quiet"; my ($valid_ref) = extract_option_value (\@opt_quiet, \$max_occurrences, \$internal_option_name, \$option_name); $valid = ${ $valid_ref }; if ($valid) { $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; } } #------------------------------------------------------------------------------ # The debug option. #------------------------------------------------------------------------------ if (@opt_debug) { $max_occurrences = 1; $internal_option_name = "debug"; $option_name = "-d/--debug"; my ($valid_ref) = extract_option_value (\@opt_debug, \$max_occurrences, \$internal_option_name, \$option_name); $valid = ${ $valid_ref }; if ($valid) #------------------------------------------------------------------------------ # Set the appropriate debug size (e.g. "XL") in a table that is used in the # gp_message() subroutine. #------------------------------------------------------------------------------ { $g_debug = $TRUE; $ignore_value = set_debug_size (); } } #------------------------------------------------------------------------------ # The verbose option. #------------------------------------------------------------------------------ if (@opt_verbose) { $max_occurrences = 1; $internal_option_name = "verbose"; $option_name = "--verbose"; my ($valid_ref) = extract_option_value (\@opt_verbose, \$max_occurrences, \$internal_option_name, \$option_name); $valid = ${ $valid_ref }; if ($valid) { $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; } } #------------------------------------------------------------------------------ # The nowarnings option. #------------------------------------------------------------------------------ if (@opt_nowarnings) { $max_occurrences = 1; $internal_option_name = "nowarnings"; $option_name = "--nowarnings"; my ($valid_ref) = extract_option_value (\@opt_nowarnings, \$max_occurrences, \$internal_option_name, \$option_name); $valid = ${ $valid_ref }; if ($valid) { $g_warnings = $g_user_settings{"nowarnings"}{"current_value"} eq "on" ? $FALSE : $TRUE; } } #------------------------------------------------------------------------------ # The warnings option (deprecated). #------------------------------------------------------------------------------ if (@opt_warnings) { $max_occurrences = 1; $internal_option_name = "warnings"; $option_name = "--warnings"; my ($valid_ref) = extract_option_value (\@opt_warnings, \$max_occurrences, \$internal_option_name, \$option_name); } #------------------------------------------------------------------------------ # At this point, the debug, verbose, warnings and quiet settings are known. # This subroutine makes the final decision on these settings. For example, if # quiet mode has been specified, the settings for debug, verbose and warnings # are ignored. #------------------------------------------------------------------------------ $ignore_value = finalize_special_options (); #------------------------------------------------------------------------------ # A this point we know we can start printing messages in case verbose and/or # debug mode have been set. #------------------------------------------------------------------------------ $msg = "the original command line options: " . join (", ", @CopyOfARGV); gp_message ("debug", $subr_name, $msg); $msg = "the command line options after the special options: " . join (", ", @ARGV); gp_message ("debug", $subr_name, $msg); gp_message ("verbose", $subr_name, "Parsing the user options"); #------------------------------------------------------------------------------ # The output option. #------------------------------------------------------------------------------ if (@opt_output) { $max_occurrences = 1; $internal_option_name = "output"; $option_name = "-o/--output"; my ($valid_ref) = extract_option_value (\@opt_output, \$max_occurrences, \$internal_option_name, \$option_name); } #------------------------------------------------------------------------------ # The overwrite option. #------------------------------------------------------------------------------ if (@opt_overwrite) { $max_occurrences = 1; $internal_option_name = "overwrite"; $option_name = "-O/--overwrite"; my ($valid_ref) = extract_option_value (\@opt_overwrite, \$max_occurrences, \$internal_option_name, \$option_name); } #------------------------------------------------------------------------------ # The highlight-percentage option. #------------------------------------------------------------------------------ if (@opt_highlight_percentage) { $max_occurrences = 1; $internal_option_name = "highlight_percentage"; $option_name = "--highlight-percentage"; my ($valid_ref) = extract_option_value (\@opt_highlight_percentage, \$max_occurrences, \$internal_option_name, \$option_name); } #------------------------------------------------------------------------------ # The hp option (deprecated) #------------------------------------------------------------------------------ if (@opt_obsoleted_hp) { $max_occurrences = 1; $internal_option_name = "hp"; $option_name = "-hp"; my ($valid_ref) = extract_option_value (\@opt_obsoleted_hp, \$max_occurrences, \$internal_option_name, \$option_name); } #------------------------------------------------------------------------------ # By now, all options given on the command line have been processed and the # list with experiment directories is known. # # Process the remainder of ARGV, but other than the option generated by the # driver, ARGV should be empty. #------------------------------------------------------------------------------ $ignore_value = wrap_up_user_options (); # Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) # Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) # Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) # Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) # Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) if (@exp_dir_list) #------------------------------------------------------------------------------ # Print the list of the experiment directories found. # # Note that later we also check for these directories to actually exist # and be valid experiments.. #------------------------------------------------------------------------------ { $found_exp_dir = $TRUE; $msg = "the following experiment directories will be used:"; gp_message ("debug", $subr_name, $msg); for my $i (keys @exp_dir_list) { my $msg = "exp_dir_list[$i] = $exp_dir_list[$i]"; gp_message ("debug", $subr_name, $msg); } } else #------------------------------------------------------------------------------ # Print a message if the experiment list is not valid, or empty. There will # also be error messages in the buffer. These will be printed later. #------------------------------------------------------------------------------ { $msg = "experiment directory name(s) are either not valid, or missing"; gp_message ("debug", $subr_name, $msg); } return (\$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 $msg; 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 }; #------------------------------------------------------------------------------ # TBD. This part needs work. The return variables from generate_dis_html () # are not used, so the code below is meaningless, but awaiting a true fix, # the problem which appears on aarch64 is bypassed. #------------------------------------------------------------------------------ if (defined ($metric_ref)) { @metric = @{ $metric_ref }; } else { $msg = "metric_ref after generate_dis_html is undefined"; gp_message ("debug", $subr_name, $msg); } } return (0) } #-- End of subroutine parse_dis_files #------------------------------------------------------------------------------ # 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 .= "/"; 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 original list with the command line options. #------------------------------------------------------------------------------ sub print_command_line_options { my ($identifier_ref) = @_; my $identifier = ${ $identifier_ref }; my $msg; $msg = "The command line options (shown for ease of reference): "; printf ("%-9s %s\n", $identifier, ucfirst ($msg)); $msg = join (", ", @CopyOfARGV); printf ("%-9s %s\n", $identifier, $msg); # printf ("%-9s\n", $identifier); return (0); } #-- End of subroutine print_command_line_options #------------------------------------------------------------------------------ # Print all the errors messages in the buffer. #------------------------------------------------------------------------------ sub print_errors_buffer { my $subr_name = get_my_name (); my ($identifier_ref) = @_; my $ignore_value; my $msg; my $plural_or_single; my $identifier = ${ $identifier_ref }; $plural_or_single = ($g_total_error_count > 1) ? "errors have" : "error has"; if (@g_warning_msgs and $g_warnings) #------------------------------------------------------------------------------ # Make sure that all warnings are printed in case of an error. This is to # avoid that warnings get lost in case the program terminates early. #------------------------------------------------------------------------------ { $ignore_value = print_warnings_buffer (); } if (not $g_options_printed) #------------------------------------------------------------------------------ # The options are printed as part of the warnings, so only if the warnings are # not printed, we need to print them in case of errors. #------------------------------------------------------------------------------ { $g_options_printed = $TRUE; $ignore_value = print_command_line_options (\$identifier); } $msg = "a total of " . $g_total_error_count; $msg .= " fatal " . $plural_or_single . " been detected:"; printf ("%-9s %s\n", $identifier, ucfirst ($msg)); for my $key (keys @g_error_msgs) { $msg = $g_error_msgs[$key]; printf ("%-11s %s\n", $identifier, ucfirst ($msg)); } return (0); } #-- End of subroutine print_errors_buffer #------------------------------------------------------------------------------ # Print the help overview #------------------------------------------------------------------------------ sub print_help_info { my $space = " "; printf("%s\n", "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)"); printf("\n"); printf("%s\n", "Process one or more experiments to generate a directory containing the"); printf("%s\n", "index.html file that may be used to browse the experiment data."); printf("\n"); printf("%s\n", "Options:"); printf("\n"); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("--help", "Print usage information and exit."); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("--version", "Print the version number and exit."); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("--verbose", "Enable verbose mode to show diagnostic messages about the"); print_help_line ("", "processing of the data. By default verbose mode is disabled."); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("-d [<db-vol-size>], --debug[=<db-vol-size>]", "Control the printing of run time debug information to assist with"); print_help_line ("", "the troubleshooting, or further development of this tool."); print_help_line ("", "The <db-vol-size> parameter controls the output volume and is"); print_help_line ("", "one from the list {s | S | m | M | l | L | xl | XL}."); print_help_line ("", "If db-vol-size is not specified, a modest amount of information"); print_help_line ("", "is printed. This is equivalent to select size s, or S. The"); print_help_line ("", "volume of data goes up as the size increases. Note that"); print_help_line ("", "currently l/L is equivalent to xl/XL, but this is expected to"); print_help_line ("", "change in future updates. By default debug mode is disabled."); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("--highlight-percentage=<value>", "A percentage value in the interval [0,100] to select and color"); print_help_line ("", "code source lines, as well as instructions, that are within this"); print_help_line ("", "percentage of the maximum metric value(s). A value of zero"); print_help_line ("", "disables this feature. The default value is 90 (%)."); #-------Marker line - do not go beyond this line ---------------------------- print_help_line ("-o <dirname>, --output=<dirname>", "Use <dirname> as the directory name to store the results in."); print_help_line ("", "In absence of this option, the default name is display.<n>.html."); print_help_line ("", "This directory is created in the current directory. The number"); print_help_line ("", "<n> is the first positive integer number not in use in this"); print_help_line ("", "naming scheme. An existing directory with the same name is not"); print_help_line ("", "overwritten. Make sure that umask is set to the correct access"); print_help_line ("", "permissions."); #-------Marker line - do not go beyond this line -------------------------- print_help_line ("-O <dirname>, --overwrite=<dirname>", "Use <dirname> as the directory name to store the results in."); print_help_line ("", "In absence of this option, the default name is display.<n>.html."); print_help_line ("", "This directory is created in the current directory. The number"); print_help_line ("", "<n> is the first positive integer number not in use in this"); print_help_line ("", "naming scheme. An existing directory with the same name is"); print_help_line ("", "silently overwritten. Make sure that umask is set to the"); print_help_line ("", "correct access permissions."); #-------Marker line - do not go beyond this line -------------------------- print_help_line ("-q, --quiet", "Disable the display of all warning, debug, verbose and any"); print_help_line ("", "other messages. If enabled, the settings for verbose and debug"); print_help_line ("", "are accepted, but ignored. With this option, there is no screen"); print_help_line ("", "output, other than errors. By default quiet mode is disabled"); #-------Marker line - do not go beyond this line -------------------------- print_help_line ("--nowarnings", "Disable the printing of warning messages on stdout. By default"); print_help_line ("", "warning messages are printed."); #-------Marker line - do not go beyond this line -------------------------- printf("\n"); printf ("%s\n","Report bugs to <https://sourceware.org/bugzilla/>"); return (0); } #-- End of subroutine print_help_info #------------------------------------------------------------------------------ # Print a single line as part of the help output. # # If the first item is not the empty string, it is considered to be the # option. If the length of the option exceeds the limit set by $max_space, # it is printed by itself and the text is printed on the next line. Otherwise # the text follows the option. # # To assist with the development of the help text, we check if the total length # of the line exceeds the max numbers of columns (79 according to the GNU # coding standards). #------------------------------------------------------------------------------ sub print_help_line { my $subr_name = get_my_name (); my ($item, $help_text) = @_; my $length_item = length ($item); my $max_col = 79; my $max_space = 14; my $no_of_spaces; my $pad; my $space = " "; my $the_message; if ($length_item > $max_col) { printf ("Error: $item is $length_item long - exceeds $max_col\n"); exit (0); } elsif ( $length_item == 0 ) { $no_of_spaces = $max_space; $pad = ""; for my $i (1..$no_of_spaces) { $pad .= $space; } $the_message = $pad . $help_text; } else { if ($length_item < $max_space) { $no_of_spaces = $max_space - length ($item); $pad = ""; for my $i (1..$no_of_spaces) { $pad .= $space; } $the_message = $item . $pad . $help_text; } else { $pad = ""; for my $i (1..$max_space) { $pad .= $space; } printf("%s\n", $item); $the_message = $pad . $help_text; } } if (length ($the_message) <= $max_col) { printf ("%s\n", $the_message); } else { my $delta = length ($the_message) - $max_col; printf ("%s\n", "$the_message - exceeds $max_col by $delta"); exit (0); } return (0); } #-- End of subroutine print_help_line #------------------------------------------------------------------------------ # Print the meta data for each experiment directory. #------------------------------------------------------------------------------ sub print_meta_data_experiments { my $subr_name = get_my_name (); 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 $data_type; my $debug_size_value = $g_user_settings{"debug"}{"current_value"}; my $db_size; my $defined; my $keyword; my $leftover; my $padding; my $user_option; my $value; my $HEADER_LIMIT = 79; my $header = sprintf ("%-20s %-22s %8s %s", "keyword", "option", "user set", "internal 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 $key (sort keys %g_user_settings) { $keyword = $key; $user_option = $g_user_settings{$key}{"option"}; $defined = ($g_user_settings{$key}{"defined"} ? "set" : "not set"); $data_type = $g_user_settings{$key}{"data_type"}; if (defined ($g_user_settings{$key}{"current_value"})) { $value = $g_user_settings{$key}{"current_value"}; if ($data_type eq "boolean") { $value = $value ? "on" : "off"; } #------------------------------------------------------------------------------ # In case of the debug option, we add the "(size)" string to remind the user # that this is the size. #------------------------------------------------------------------------------ if ($key eq "debug") { $db_size = ($debug_size_value eq "on") ? "s" : $debug_size_value; $value = $db_size . " (size)"; } } else { $value = "undefined"; } my $print_line = sprintf ("%-20s %-22s %8s %s", $keyword, $user_option, $defined, $value); gp_message ($mode, $subr_name, $print_line); } } #-- End of subroutine print_table_user_settings #------------------------------------------------------------------------------ # Dump the contents of nested hash "g_user_settings". Some simple formatting # 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 $key (keys %g_user_settings) { my $print_line = sprintf ("%-20s =>", $key); for my $fields (sort keys %{ $g_user_settings{$key} }) { if (defined ($g_user_settings{$key}{$fields})) { $keyword_value_pair = $fields." = ".$g_user_settings{$key}{$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 #------------------------------------------------------------------------------ # Dump all the warning messages in the buffer. #------------------------------------------------------------------------------ sub print_warnings_buffer { my $subr_name = get_my_name (); my $ignore_value; my $msg; if (not $g_options_printed) #------------------------------------------------------------------------------ # Only if the options have not yet been printed, print them. #------------------------------------------------------------------------------ { $g_options_printed = $TRUE; $ignore_value = print_command_line_options (\$g_warn_keyword); } for my $i (keys @g_warning_msgs) { $msg = $g_warning_msgs[$i]; if ($msg =~ /^$g_html_new_line/) { $msg =~ s/$g_html_new_line//; printf ("%-9s\n", $g_warn_keyword); } printf ("%-9s %s\n", $g_warn_keyword, ucfirst ($msg)); } return (0); } #-- End of subroutine print_warnings_buffer #------------------------------------------------------------------------------ # Process the call tree input data and generate HTML output. #------------------------------------------------------------------------------ sub process_calltree { my $subr_name = get_my_name (); my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, $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 $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])'; my $remove_number_regex = '^\d+:'; my $replace_quote_regex = '"/\"'; 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"}; #------------------------------------------------------------------------------ # Strip the internal number from the address field. #------------------------------------------------------------------------------ $address_field =~ s/$remove_number_regex//; ## $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"; #------------------------------------------------------------------------------ ## TBD: adding the address is not supported. Need to find a way to figure ## out the ID of the function. ## print SCRIPT "disasm \"$tmp\" $address_field\n"; ## print SCRIPT "source \"$tmp\" $address_field\n"; #------------------------------------------------------------------------------ print SCRIPT "disasm \"$tmp\"\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\"\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", $subr_name, "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 $marker; my $name_regex; my $no_of_fields; my $metrics_length; my $missing_digits; my $msg; 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 = '\/'; $msg = "enter subroutine " . $subr_name; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ if (is_file_empty ($overview_file)) { gp_message ("assertion", $subr_name, "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"); #------------------------------------------------------------------------------ # Remove a legacy redundant string, if any. #------------------------------------------------------------------------------ @function_data = @{ remove_redundant_string (\@function_data)}; #------------------------------------------------------------------------------ # 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]; ## $input_line =~ s/ -- no functions found//; 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; $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/))) { $msg = "detected a line with function data"; gp_message ("debugXL", $subr_name, $msg); my ($hex_address_ref, $marker_ref, $reduced_line_ref, $list_with_metrics_ref) = split_function_data_line (\$input_line); $full_hex_address = ${ $hex_address_ref }; $marker = ${ $marker_ref }; $routine = ${ $reduced_line_ref }; $all_metrics = ${ $list_with_metrics_ref }; $msg = "RESULT full_hex_address = " . $full_hex_address; $msg .= " -- metric values = " . $all_metrics; $msg .= " -- marker = " . $marker; $msg .= " -- function name = " . $routine; 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; $msg = "no_of_fields = " . $no_of_fields; $msg .= " elements_in_name = " . $elements_in_name; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # 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"); $msg = "verify full_hex_address = " . $full_hex_address; gp_message ("debugXL", $subr_name, $msg); if ($full_hex_address =~ /$get_hex_address_regex/) { $hex_address = "0x" . $2; } else { $msg = "full_hex_address = $full_hex_address has the wrong format"; gp_message ("assertion", $subr_name, $msg); } push (@address_field, $full_hex_address); $msg = "pushed full_hex_address = " . $full_hex_address; gp_message ("debugXL", $subr_name, $msg); 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. #------------------------------------------------------------------------------ for my $i (keys @address_field) { $msg = "address_field[" . $i ."] = " . $address_field[$i]; gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ ## 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 $final_function_name; my $found_a_match = $FALSE; my $msg; my $ref_index; $msg = "on entry - routine = " . $routine; $msg .= " current_address = " . $current_address; gp_message ("debugM", $subr_name, $msg); #------------------------------------------------------------------------------ # 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})) { $msg = "$g_multi_count_function{$routine} exists"; gp_message ("debugXL", $subr_name, $msg); $msg = "g_function_occurrences{$routine} = "; $msg .= $g_function_occurrences{$routine}; gp_message ("debugXL", $subr_name, $msg); 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. #------------------------------------------------------------------------------ { $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 { $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) { $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]; $msg = "leave subroutine " . $subr_name; gp_message ("debug", $subr_name, $msg); 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 $msg; my $summary_metrics; my $detail_metrics; my $detail_metrics_system; my $call_metrics; if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") { $msg = "g_user_settings{default_metrics}{current_value} = "; $msg .= $g_user_settings{"default_metrics"}{"current_value"}; gp_message ("debug", $subr_name, $msg); # 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; $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. # # # TBD: Does not yet use the warnings/error system. This needs to be fixed. #------------------------------------------------------------------------------ sub process_rc_file { my $subr_name = get_my_name (); my ($rc_file_name, $rc_file_paths_ref) = @_; #------------------------------------------------------------------------------ # Local structures. #------------------------------------------------------------------------------ # Stores the values extracted from the config file: my %rc_settings_user = (); my %error_and_warning_msgs = (); my @rc_file_paths = (); my @split_line; my @my_fields; my $msg; my $first_part; my $line; my $line_number; my $no_of_arguments; my $number_of_fields; my $number_of_paths; my $parse_errors; #-- Count the number of errors my $parse_warnings; #-- Count the number of errors 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. #------------------------------------------------------------------------------ $msg = "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"; gp_message ("debug", $subr_name, $msg); $rc_file_found = $FALSE; for my $path_name (@rc_file_paths) { $rc_config_file = $path_name . "/" . $rc_file_name; $msg = "looking for configuration file " . $rc_config_file; gp_message ("debug", $subr_name, $msg); if (-f $rc_config_file) { $msg = "found configuration file " . $rc_config_file; gp_message ("debug", $subr_name, $msg); $rc_file_found = $TRUE; last; } } if (not $rc_file_found) #------------------------------------------------------------------------------ # There is no configuration file and we can skip this subroutine. #------------------------------------------------------------------------------ { $msg = "configuration file $rc_file_name not found"; gp_message ("verbose", $subr_name, $msg); return (0); } else { $msg = "unable to open file $rc_config_file for reading:"; open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file") or die ($subr_name . " - " . $msg . " " . $!); #------------------------------------------------------------------------------ # The configuration file has been opened for reading. #------------------------------------------------------------------------------ $msg = "file $rc_config_file has been opened for reading"; gp_message ("debug", $subr_name, $msg); } $msg = "found configuration file $rc_config_file"; gp_message ("verbose", $subr_name, $msg); $msg = "processing configuration file " . $rc_config_file; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Here we scan the configuration file for the settings. # # 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++; $msg = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 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); $msg = "number of fields = " . $number_of_fields; gp_message ("debug", $subr_name, $msg); } if ($number_of_fields ge 3) #------------------------------------------------------------------------------ # This is not supported. #------------------------------------------------------------------------------ { $parse_errors++; $msg = "more than 2 fields found: $first_part"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 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 { $msg = "[line $line_number] $rc_config_file -"; $msg .= " number of fields = $number_of_fields"; gp_message ("assertion", $subr_name, $msg); } #------------------------------------------------------------------------------ # Store the keyword, value and line number. #------------------------------------------------------------------------------ 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) { $msg = "option $rc_keyword previously set at line"; $msg .= " $prev_line_number: new value '$rc_value'"; $msg .= " ' overrides '$prev_value'"; } else { $msg = "option $rc_keyword previously set to the same value"; $msg .= " at line $prev_line_number"; } $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $msg; } $rc_settings_user{$rc_keyword}{"value"} = $rc_value; $rc_settings_user{$rc_keyword}{"line_no"} = $line_number; gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); gp_message ("debug", $subr_name, "stored value = $rc_value"); gp_message ("debug", $subr_name, "stored line number = $line_number"); } #------------------------------------------------------------------------------ # 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"}; $msg = "keyword = " . $keyword . " value = " . $key_value; gp_message ("debug", $subr_name, $msg); } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { $msg = "before config file: $rc_keyword $fields ="; $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; gp_message ("debug", $subr_name, $msg); } } #------------------------------------------------------------------------------ # We are almost done. Check for all keywords found whether they are valid. # 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? #------------------------------------------------------------------------------ $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"}; $msg = "input value '$input_value' for keyword"; $msg .= " $rc_keyword is not valid"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; next; } } else #------------------------------------------------------------------------------ # This keyword requires a value, but none has been found. #------------------------------------------------------------------------------ { $parse_errors++; $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; $msg = "missing value for keyword '$rc_keyword'"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 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"}; $msg = "keyword $rc_keyword is not supported"; $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; } } for my $rc_keyword (keys %g_user_settings) { for my $fields (keys %{ $g_user_settings{$rc_keyword} }) { $msg = "after config file: $rc_keyword $fields ="; $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; gp_message ("debug", $subr_name, $msg); } } print_table_user_settings ("debug", "upon the return from $subr_name"); if ( ($parse_errors == 0) and ($parse_warnings == 0) ) { $msg = "successfully parsed and processed the configuration file"; gp_message ("verbose", $subr_name, $msg); } else { if ($parse_errors > 0) { my $plural_or_single = ($parse_errors > 1) ? "errors" : "error"; $msg = $g_error_keyword . "found $parse_errors fatal"; $msg .= " " . $plural_or_single . " in the configuration file:"; gp_message ("debug", $subr_name, $msg); #------------------------------------------------------------------------------ # Sort the hash keys, the line numbers, alphabetically and print the # corresponding error messages. #------------------------------------------------------------------------------ for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} })) { $msg = $g_error_keyword . "[line $line_no] in file"; $msg .= $rc_config_file . " - "; $msg .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; gp_message ("debug", $subr_name, $msg); } } if (not $g_quiet) { if ($parse_warnings > 0) { $msg = $g_warn_keyword . " found $parse_warnings warnings in"; $msg .= " the configuration file:"; gp_message ("debug", $subr_name, $msg); for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} })) { $msg = $g_warn_keyword; $msg .= " [line $line_no] in file $rc_config_file - "; $msg .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; gp_message ("debug", $subr_name, $msg); } } } } 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; $msg = "target function $routine not found in $base - " . "links to source code involving this function will not work"; gp_message ("debug", $subr_name, $msg); gp_message ("warning", $subr_name, $msg); $g_total_warning_count++; 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"; $threshold_line .= " (--highlight-percentage) option:"; $threshold_line .= " " . $rounded_percentage . " (%)</i>"; } else { $threshold_line = "<i>The highlight percentage feature has not been"; $threshold_line .= " 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 $abs_path_dir; my @candidate_ignored_metrics = (); my $error_code; my $hp_value; my $msg; my $outputdir; my $target_cmd; my $rm_output_msg; my $mkdir_output_msg; my $time_percentage_multiplier; my $process_all_functions; #------------------------------------------------------------------------------ # 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) { $msg = "the -o/--output and -O/--overwrite options are both set, " . "but are mutually exclusive"; gp_message ("error", $subr_name, $msg); $msg = "(setting for -o = $dir_o_option, " . "setting for -O = $dir_O_option)"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } #------------------------------------------------------------------------------ # The warnings option is deprecated. Print a warning to this extent and point # to the --nowarnings option. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # Handle the situation that both or one of the highlight-percentage and hp # options are set. #------------------------------------------------------------------------------ if ($g_user_settings{"warnings"}{"defined"}) { $msg = "<br>" . "the --warnings option has been deprecated and"; $msg .= " will be ignored"; gp_message ("warning", $subr_name, $msg); if ($g_user_settings{"nowarnings"}{"defined"}) { $msg = "since the --nowarnings option is also used, warnings"; $msg .= " are disabled"; gp_message ("warning", $subr_name, $msg); } else { $msg = "by default, warnings are enabled and can be disabled with"; gp_message ("warning", $subr_name, $msg); $msg = " the --nowarnings option"; gp_message ("warning", $subr_name, $msg); } $g_total_warning_count++; } #------------------------------------------------------------------------------ # In case both the --highlight-percentage and -hp option are set, issue a # warning and continue with the --highlight-percentage value. #------------------------------------------------------------------------------ if ($g_user_settings{"hp"}{"defined"}) { $msg = "<br>" . "the -hp option has been deprecated and"; $msg .= " will be ignored"; gp_message ("warning", $subr_name, $msg); if ($g_user_settings{"highlight_percentage"}{"defined"}) { $msg = "since the --highlight-percentage option is also used,"; $msg .= " the value of "; $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; $msg .= " will be applied"; gp_message ("warning", $subr_name, $msg); } else { #------------------------------------------------------------------------------ # If only the -hp option is set, we use it, because we do not want to break # compatibility (yet) and force the user to change the option. #------------------------------------------------------------------------------ ## FUTURE $msg = "instead, the default setting of " ## FUTURE $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; ## FUTURE $msg .= " for the --highlight-percentage will be used"; ## FUTURE gp_message ("warning", $subr_name, $msg); ## FUTURE $msg = "please use this option to set the highlighting value"; ## FUTURE gp_message ("warning", $subr_name, $msg); $g_user_settings{"highlight_percentage"}{"current_value"} = $g_user_settings{"hp"}{"current_value"}; $g_user_settings{"highlight_percentage"}{"defined"} = $TRUE; $msg = "for now, the value of " . $g_user_settings{"hp"}{"current_value"} . " for the -hp option is used, but please change the" . " option to --highlight-percentage"; gp_message ("warning", $subr_name, $msg); } $g_total_warning_count++; } #------------------------------------------------------------------------------ # Regardless of the use of the -hp option, we continue with the value for # highlight-percentage. Some more checks are carried out now. #------------------------------------------------------------------------------ #------------------------------------------------------------------------------ # This value should be in the interval [0,100]. # the number to be positive, but the limits have not been checked yet. #------------------------------------------------------------------------------ $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; if (($hp_value < 0) or ($hp_value > 100)) { $msg = "the value for the highlight percentage is set to $hp_value,"; $msg .= " but must be in the range [0, 100]"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } elsif ($hp_value == 0.0) #------------------------------------------------------------------------------ # A value of zero is interpreted to mean that highlighting should be disabled. # To make the checks for this later on easier, set it to an integer value of 0. #------------------------------------------------------------------------------ { $g_user_settings{"highlight_percentage"}{"current_value"} = 0; $msg = "reset the highlight percentage value from 0.0 to"; $msg .= " " . $g_user_settings{"highlight_percentage"}{"current_value"}; gp_message ("debug", $subr_name, $msg); } #------------------------------------------------------------------------------ # The value for TP should be in the interval (0,100]. We already enforced # the 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)) { $msg = "the value for the total percentage is set to $tp_value,"; $msg .= " but must be in the range (0, 100]"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } 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; } $msg = "value of time_percentage_multiplier = " . $time_percentage_multiplier; gp_message ("debugM", $subr_name, $msg); $msg = "value of process_all_functions = " . ($process_all_functions ? "TRUE" : "FALSE"); gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ # 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. #------------------------------------------------------------------------------ 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 $msg = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; gp_message ("debugM", $subr_name, $msg); } #------------------------------------------------------------------------------ # Check if the experiment directories exist and if they do, add the absolute # path. This is easier in the remainder. #------------------------------------------------------------------------------ for my $i (0 .. $#exp_dir_list) { if (-d $exp_dir_list[$i]) { $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); $exp_dir_list[$i] = $abs_path_dir; $msg = "directory $exp_dir_list[$i] exists"; gp_message ("debugM", $subr_name, $msg); } } return (\%ignored_metrics, $outputdir, $time_percentage_multiplier, $process_all_functions, \@exp_dir_list); } #-- End of subroutine process_user_options #------------------------------------------------------------------------------ # This function addresses a legacy issue. # # In binutils 2.40, the "gprofng display text" tool may add a string in the # function overviews. This did not add any value and was disruptive to the # output. It has been removed in 2.41, but in order to support the older # versions of gprofng, the string is removed before the data is processed. # # Note: the double space in "-- no" is not a typo in this code! #------------------------------------------------------------------------------ sub remove_redundant_string { my $subr_name = get_my_name (); my ($target_array_ref) = @_; my @target_array = @{ $target_array_ref }; my $msg; my $redundant_string = " -- no functions found"; for (my $line = 0; $line <= $#target_array; $line++) { $target_array[$line] =~ s/$redundant_string//; } $msg = "removed any occurrence of " . $redundant_string; gp_message ("debugM", $subr_name, $msg); return (\@target_array); } #-- End of subroutine remove_redundant_string #------------------------------------------------------------------------------ # 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 = lc ($g_user_settings{"debug"}{"current_value"}); #------------------------------------------------------------------------------ # Set the corresponding sizes in the table. A value of "on" is equivalent to # size "s". #------------------------------------------------------------------------------ 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 = $FALSE; $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 :-) #------------------------------------------------------------------------------ my $show_sizes = $FALSE; if ($show_sizes) { if ($g_debug_size{$debug_value}) { for my $i (keys %g_debug_size) { print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; } } } return (0); } #-- 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 $file_is_empty; 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") { $file_is_empty = is_file_empty ($filename); if ($file_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") { $msg = "unable to open disassembly file $filename for reading:"; open ($DIS, "<", $filename) or die ($subr_name . " - " . $msg . " " . $!); gp_message ("debug", $subr_name, "opened file $filename for reading"); $file_is_empty = is_file_empty ($filename); if ($file_is_empty) #------------------------------------------------------------------------------ # Currently, the disassembly file for <static> functions appears to be empty # on aarch64. This might be a bug, but it is in any case better to handle # this situation. #------------------------------------------------------------------------------ { $first_line = ""; $msg = "file $filename is empty"; gp_message ("debugM", $subr_name, $msg); } else { $first_line = <$DIS>; } close ($DIS); if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) { $src_file = "$1" } 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 to store the # results in is created. #------------------------------------------------------------------------------ sub set_up_output_directory { my $subr_name = get_my_name (); my $error_code; my $msg; my $mkdir_output_msg; my $outputdir = "does_not_exist_yet"; my $rm_output_msg; my $success; my $target_cmd; my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; 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. #------------------------------------------------------------------------------ $msg = "the target output directory is $outputdir"; gp_message ("debug", $subr_name, $msg); if (-d $outputdir) { #------------------------------------------------------------------------------ # The -o option is used, but the directory already exists. #------------------------------------------------------------------------------ if ($define_new_output_dir) { $msg = "directory $outputdir already exists"; gp_message ("error", $subr_name, $msg); $msg = "use the -O/--overwite option to overwrite an"; $msg .= " existing directory"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } 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 "*") { $msg = "it is not allowed to use * as a value for the -O option"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } 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) { $msg = "fatal error when trying to remove $outputdir"; gp_message ("error", $subr_name, $rm_output_msg); gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } else { $msg = "directory $outputdir has been removed"; gp_message ("debug", $subr_name, $msg); } } } } #-- End of if-check for $outputdir #------------------------------------------------------------------------------ # When we get here, the fatal scenarios have not occurred and the name for # $outputdir is known. Time to create it. Note that recursive creation is # supported and the user umask settings control the access permissions. #------------------------------------------------------------------------------ $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir; ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd); if ($error_code != 0) { $msg = "a fatal problem occurred when creating directory $outputdir"; gp_message ("error", $subr_name, $mkdir_output_msg); gp_message ("error", $subr_name, $msg); $g_total_error_count++; gp_message ("abort", $subr_name, $g_abort_msg); } else { $msg = "created output directory $outputdir"; gp_message ("debug", $subr_name, $msg); } return ($outputdir); } #-- End of subroutine set_up_output_directory #------------------------------------------------------------------------------ # Split a line with function data into 3 components. #------------------------------------------------------------------------------ sub split_function_data_line { my $subr_name = get_my_name (); my ($input_line_ref) = @_; my $input_line = ${ $input_line_ref }; my $decimal_separator = $g_locale_settings{"decimal_separator"}; my $full_hex_address; my $function_name; my $hex_address; my $length_metric_list; my $length_remainder; my $length_target_string; my $list_with_metrics; my $marker; my $msg; my $reduced_line; my $remainder; my @hex_addresses = (); my @special_marker = (); my @the_function_name = (); my $find_hex_address_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(.*)'; my $find_marker_regex = '(^\*).*'; my $find_metrics_1_regex = '\)*\ +([0-9,' . $decimal_separator; $find_metrics_1_regex .= '\ ]*$)'; my $find_metrics_2_regex = '\)*\ +\[.+\]\s+([0-9,' . $decimal_separator; $find_metrics_2_regex = '\ ]*$)'; my $get_hex_address_regex = '(\d+):0x(\S+)'; $reduced_line = $input_line; if ($input_line =~ /$find_hex_address_regex/) { if (defined ($1) ) { $full_hex_address = $1; $reduced_line =~ s/$full_hex_address//; $msg = "full_hex_address = " . $full_hex_address; gp_message ("debugXL", $subr_name, $msg); $msg = "reduced_line = " . $reduced_line; gp_message ("debugXL", $subr_name, $msg); } if (defined ($2) ) { $remainder = $2; $msg = "remainder = " . $remainder; gp_message ("debugXL", $subr_name, $msg); if (($remainder =~ /$find_metrics_1_regex/) or ($remainder =~ /$find_metrics_2_regex/)) { if (defined ($1)) { $list_with_metrics = $1; $msg = "before list_with_metrics = " . $list_with_metrics; gp_message ("debugXL", $subr_name, $msg); $list_with_metrics =~ s/$g_rm_surrounding_spaces_regex//g; $msg = "after list_with_metrics = " . $list_with_metrics; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # Remove the function name from the string. #------------------------------------------------------------------------------ $length_remainder = length ($remainder); $length_metric_list = length ($list_with_metrics); $msg = "length remainder = " . $length_remainder; gp_message ("debugXL", $subr_name, $msg); $msg = "length list_with_metrics = " . $length_metric_list; gp_message ("debugXL", $subr_name, $msg); $length_target_string = $length_remainder - $length_metric_list - 1; $function_name = substr ($remainder, 0, $length_target_string, ''); $msg = "new function_name = " . $function_name; gp_message ("debugXL", $subr_name, $msg); $reduced_line = $function_name; $reduced_line =~ s/$g_rm_surrounding_spaces_regex//g; $msg = "reduced_line = " . $reduced_line; gp_message ("debugXL", $subr_name, $msg); #------------------------------------------------------------------------------ # In some lines, the function name has a "*" prepended. Isolate this marker # and later on remove it from the function name. # TBD: Can probably be done more efficiently. #------------------------------------------------------------------------------ if ($reduced_line =~ /$find_marker_regex/) { if (defined ($1)) { $marker = $1; $msg = "found the marker = " . $marker; gp_message ("debugXL", $subr_name, $msg); } else { $msg = "first character in " . $reduced_line ; $msg .= " is not expected"; gp_message ("assertion", $subr_name, $msg); } } else { $marker = "X"; } } else { $msg = "failure to find metric values following the "; $msg .= "function name"; gp_message ("assertion", $subr_name, $msg); } } else { $msg = "cannot find metric values in remainder"; gp_message ("debugXL", $subr_name, $msg); gp_message ("assertion", $subr_name, $msg); } } #------------------------------------------------------------------------------ # We now have the 3 main objects from the input line. Next, they are processed # and stored. #------------------------------------------------------------------------------ if ($full_hex_address =~ /$get_hex_address_regex/) { if (defined ($1) and defined ($2)) { $hex_address = "0x" . $2; push (@hex_addresses, $full_hex_address); $msg = "pushed full_hex_address = " . $full_hex_address; gp_message ("debugXL", $subr_name, $msg); } } else { $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"); } $reduced_line =~ s/^\*//; $msg = "RESULT full_hex_address = " . $full_hex_address; $msg .= " -- metric values = " . $list_with_metrics; $msg .= " -- marker = " . $marker; $msg .= " -- function name = " . $reduced_line; gp_message ("debugXL", $subr_name, $msg); } return (\$full_hex_address, \$marker, \$reduced_line, \$list_with_metrics); } #-- End of subroutine split_function_data_line #------------------------------------------------------------------------------ # 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 $msg; 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}) { $msg = "target_name = $target_name is already defined: "; $msg .= $g_tagged_names{$target_name}; gp_message ("debug", $subr_name, $msg); $msg = "target_name on return = $target_name"; gp_message ("debug", $subr_name, $msg); return ($g_tagged_names{$target_name}); } else { $unique_name = "ftag".$S_total_tagged_names; $S_total_tagged_names++; $g_tagged_names{$target_name} = $unique_name; $msg = "target_name = $target_name is new and added: "; $msg .= "g_tagged_names{$target_name} = $g_tagged_names{$target_name}"; gp_message ("debug", $subr_name, $msg); $msg = "target_name on return = $target_name"; gp_message ("debug", $subr_name, $msg); return ($unique_name); } } #-- 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 $msg; my $ref_executable_name; my $first_exp_dir = $TRUE; my $count_differences = 0; #------------------------------------------------------------------------------ # Enforce that the full path names to the executable are the same. This could # be overkill and a checksum approach would be more flexible. #------------------------------------------------------------------------------ for my $full_exp_dir (@exp_dir_list) { my $exp_dir = get_basename ($full_exp_dir); 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"}; $msg = "ref_executable_name = " . $ref_executable_name; gp_message ("debug", $subr_name, $msg); next; } $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; $msg = "full_path_executable_name = " . $full_path_executable_name; gp_message ("debug", $subr_name, $msg); if ($full_path_executable_name ne $ref_executable_name) { $count_differences++; $msg = $full_path_executable_name . " does not match"; $msg .= " " . $ref_executable_name; gp_message ("debug", $subr_name, $msg); } } $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 $msg; 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 { $msg = "the $data_type data type for input $input_item is not supported"; gp_message ("assertion", $subr_name, $msg); } return ($return_value); } #-- End of subroutine verify_if_input_is_valid #------------------------------------------------------------------------------ # Scan the leftovers in ARGV. Other than the option generated by the driver, # this list should be empty. Anything left here is considered to be a fatal # error and pushed into the g_error_msgs buffer. # # We use two different arrays for the errors found. This allows us to group # the same type of errors. #------------------------------------------------------------------------------ sub wrap_up_user_options { my $subr_name = get_my_name (); my @opt_unsupported = (); my @opt_ignored = (); my $current_option; my $driver_inserted = "--whoami=gprofng display html"; my $ignore_option; my $msg; my $option_delimiter = "--"; if (@ARGV) { $msg = "items in ARGV: " . join (" ", @ARGV); gp_message ("debugXL", $subr_name, $msg); $ignore_option = $FALSE; for my $i (keys @ARGV) { $current_option = $ARGV[$i]; $msg = "ARGV[$i] = $current_option"; if ($current_option eq $option_delimiter) #------------------------------------------------------------------------------ # The user may use a feature of GetOptions to delimit the options. After # this, only experiment names are allowed and these have been handled already, # so anything found after this delimite is an error. # # This is why we set a flag if the delimiter has been found. #------------------------------------------------------------------------------ { $ignore_option = $TRUE; gp_message ("debugXL", $subr_name, $msg . " (option delimiter)"); } elsif ($ignore_option) #------------------------------------------------------------------------------ # We have seen the delimiter, but there are still options, or other strings. # In any case, it is not allowed. #------------------------------------------------------------------------------ { push (@opt_ignored, $current_option); gp_message ("debugXL", $subr_name, $msg . " (ignored)"); } elsif ($current_option ne $driver_inserted) #------------------------------------------------------------------------------ # The gprofng driver inserts this and it should be ignored. This is why we # only recorded those options different than the one inserted by the driver. #------------------------------------------------------------------------------ { push (@opt_unsupported, $current_option); gp_message ("debugXL", $subr_name, $msg . " (unsupported)"); } else #------------------------------------------------------------------------------ # The gprofng driver inserts this option and it should be ignored. #------------------------------------------------------------------------------ { gp_message ("debugXL", $subr_name, $msg . " (driver inserted and ignored)"); } } } #------------------------------------------------------------------------------ # Store any illegal input in the g_error_msgs buffer. #------------------------------------------------------------------------------ if (@opt_ignored) { $msg = "the following input is out of place:"; for my $i (keys @opt_ignored) { $msg .= " " . $opt_ignored[$i]; } gp_message ("error", $subr_name, $msg); $g_total_error_count++; } if (@opt_unsupported) { $msg = "the following items in the input are not supported:"; for my $i (keys @opt_unsupported) { $msg .= " " . $opt_unsupported[$i]; } gp_message ("error", $subr_name, $msg); $msg = "perhaps an error in the option name, or an option value"; $msg .= " is missing?"; gp_message ("error", $subr_name, $msg); $g_total_error_count++; } return (0); } #-- End of subroutine wrap_up_user_options

Es la eliminación del sarro y la placa adherida a la superficie de los dientes mediante un equipo de ultrasonidos que garantiza la integridad de las piezas dentales a la vez que elimina en profundidad cualquier resto de suciedad.

A continuación se procede al pulido de los dientes mediante una fresa especial que elimina la placa bacteriana y devuelve a los dientes el aspecto sano que deben tener.

Una vez terminado todo el proceso, se mantiene al perro en observación hasta que se despierta de la anestesia, bajo la atenta supervisión de un veterinario.

¿Cada cuánto tiempo tengo que hacerle una limpieza dental a mi perro?

A partir de cierta edad, los perros pueden necesitar una limpieza dental anual o bianual. Depende de cada caso. En líneas generales, puede decirse que los perros de razas pequeñas suelen acumular más sarro y suelen necesitar una atención mayor en cuanto a higiene dental.

Riesgos de una mala higiene

Los riesgos más evidentes de una mala higiene dental en los perros son los siguientes:

Cuando la acumulación de sarro no se trata, se puede producir una inflamación y retracción de las encías que puede descalzar el diente y provocar caídas.
Mal aliento (halitosis).
Sarro perros
Puede ir a más
Las bacterias de la placa pueden trasladarse a través del torrente circulatorio a órganos vitales como el corazón ocasionando problemas de endocarditis en las válvulas. Las bacterias pueden incluso acantonarse en huesos (La osteomielitis es la infección ósea, tanto cortical como medular) provocando mucho dolor y una artritis séptica).

¿Cómo se forma el sarro?

El sarro es la calcificación de la placa dental. Los restos de alimentos, junto con las bacterias presentes en la boca, van a formar la placa bacteriana o placa dental. Si la placa no se retira, al mezclarse con la saliva y los minerales presentes en ella, reaccionará formando una costra. La placa se calcifica y se forma el sarro.

El sarro, cuando se forma, es de color blanquecino pero a medida que pasa el tiempo se va poniendo amarillo y luego marrón.

Síntomas de una pobre higiene dental
La señal más obvia de una mala salud dental canina es el mal aliento.

Sin embargo, a veces no es tan fácil de detectar
Y hay perros que no se dejan abrir la boca por su dueño. Por ejemplo…

Recientemente nos trajeron a la clínica a un perro que parpadeaba de un ojo y decía su dueño que le picaba un lado de la cara. Tenía molestias y dificultad para comer, lo que había llevado a sus dueños a comprarle comida blanda (que suele ser un poco más cara y llevar más contenido en grasa) durante medio año. Después de una exploración oftalmológica, nos dimos cuenta de que el ojo tenía una úlcera en la córnea probablemente de rascarse . Además, el canto lateral del ojo estaba inflamado. Tenía lo que en humanos llamamos flemón pero como era un perro de pelo largo, no se le notaba a simple vista. Al abrirle la boca nos llamó la atención el ver una muela llena de sarro. Le realizamos una radiografía y encontramos una fístula que llegaba hasta la parte inferior del ojo.

Le tuvimos que extraer la muela. Tras esto, el ojo se curó completamente con unos colirios y una lentilla protectora de úlcera. Afortunadamente, la úlcera no profundizó y no perforó el ojo. Ahora el perro come perfectamente a pesar de haber perdido una muela.

¿Cómo mantener la higiene dental de tu perro?
Hay varias maneras de prevenir problemas derivados de la salud dental de tu perro.

Limpiezas de dientes en casa
Es recomendable limpiar los dientes de tu perro semanal o diariamente si se puede. Existe una gran variedad de productos que se pueden utilizar:

Pastas de dientes.
Cepillos de dientes o dedales para el dedo índice, que hacen más fácil la limpieza.
Colutorios para echar en agua de bebida o directamente sobre el diente en líquido o en spray.

En la Clínica Tus Veterinarios enseñamos a nuestros clientes a tomar el hábito de limpiar los dientes de sus perros desde que son cachorros. Esto responde a nuestro compromiso con la prevención de enfermedades caninas.

Hoy en día tenemos muchos clientes que limpian los dientes todos los días a su mascota, y como resultado, se ahorran el dinero de hacer limpiezas dentales profesionales y consiguen una mejor salud de su perro.

Limpiezas dentales profesionales de perros y gatos

Recomendamos hacer una limpieza dental especializada anualmente. La realizamos con un aparato de ultrasonidos que utiliza agua para quitar el sarro. Después, procedemos a pulir los dientes con un cepillo de alta velocidad y una pasta especial. Hacemos esto para proteger el esmalte.

La frecuencia de limpiezas dentales necesaria varía mucho entre razas. En general, las razas grandes tienen buena calidad de esmalte, por lo que no necesitan hacerlo tan a menudo e incluso pueden pasarse la vida sin requerir una limpieza. Sin embargo, razas pequeñas como el Yorkshire o el Maltés, deben hacérselas todos los años desde cachorros si se quiere conservar sus piezas dentales.

Otro factor fundamental es la calidad del pienso. Algunas marcas han diseñado croquetas que limpian la superficie del diente y de la muela al masticarse.

Ultrasonido para perros

¿Se necesita anestesia para las limpiezas dentales de perros y gatos?

La limpieza dental en perros no es una técnica que pueda practicarse sin anestesia general , aunque hay veces que los propietarios no quieren anestesiar y si tiene poco sarro y el perro es muy bueno se puede intentar…… , pero no se va a poder pulir ni acceder a todas la zona de la boca …. Además los limpiadores dentales van a irrigar agua y hay riesgo de aspiración a vías respiratorias si no se realiza una anestesia correcta con intubación traqueal . En resumen , sin anestesia no se va hacer una correcta limpieza dental.

Tampoco sirve la sedación ya que necesitamos que el animal esté totalmente quieto, y el veterinario tenga un acceso completo a todas sus piezas dentales y encías.

Alimentos para la limpieza dental

Hay que tener cierto cuidado a la hora de comprar determinados alimentos porque no todos son saludables. Algunos tienen demasiado contenido graso, que en exceso puede causar problemas cardiovasculares y obesidad.

Los mejores alimentos para los dientes son aquellos que están elaborados por empresas farmacéuticas y llevan componentes químicos con tratamientos específicos para el diente del perro. Esto implica no solo limpieza a través de la acción mecánica de morder sino también un tratamiento antibacteriano para prevenir el sarro.

Conclusión

Si eres como la mayoría de dueños, por falta de tiempo , es probable que no estés prestando la suficiente atención a la limpieza dental de tu perro. Por eso te animamos a que comiences a limpiar los dientes de tu perro y consideres atender a su higiene bucal con frecuencia.

Estas simples medidas pueden conllevar a que tu perro tenga una vida más larga y mucho más saludable.

Si te resulta imposible introducir un cepillo de dientes a tu perro en la boca, pásate con él por clínica Tus Veterinarios y te explicamos cómo hacerlo.

Necesitas hacer una limpieza dental profesional a tu mascota?
Llámanos al 622575274 o contacta con nosotros

¿Cada cuánto tiempo tengo que hacerle una limpieza dental a mi perro?

Riesgos de una mala higiene

¿Cómo se forma el sarro?

Limpiezas dentales profesionales de perros y gatos

Ultrasonido para perros

Alimentos para la limpieza dental

Conclusión

Deja un comentario Cancelar respuesta

Entradas recientes

Horarios

Donde estamos

Síguenos