| #!/usr/bin/env 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; |
| |
| #------------------------------------------------------------------------------ |
| # 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]'; |
| |
| #------------------------------------------------------------------------------ |
| # 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 = "BINUTILS_VERSION"; |
| $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 }; |
| |
| 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); |
| |
| # gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line"); |
| |
| $line_n++; |
| if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign |
| { |
| #------------------------------------------------------------------------------ |
| # A typical target line looks like this: |
| # 11:0x001492e0 6976.900 <additional_timings> _lwp_start |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "select = $line"); |
| if ($is_calls) |
| { |
| $segment = $3; |
| $offset = $5; |
| $spaces = $6; |
| $rest = $7; |
| $PC_Address = $segment.$4.$offset; # PC Addr. |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7"); |
| } |
| else |
| { |
| $segment = $2; |
| $offset = $4; |
| $spaces = $5; |
| $rest = $6; |
| $PC_Address = $segment.$3.$offset; # PC Addr. |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); |
| gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); |
| } |
| if ($segment == -1) |
| { |
| #------------------------------------------------------------------------------ |
| # presume vDSO field overflow - er_print used an inadequate format |
| # or the fsummary (MASTER) had the wrong format for -1? |
| # rats - get ahead of ourselves - should not be a field abuttal so |
| #------------------------------------------------------------------------------ |
| if ($line =~ /$name_regex/) |
| { |
| if ($metric_ok) |
| { |
| $metric_value = $1; # whatever |
| $routine = $2; |
| } |
| else |
| { |
| $routine = $1; |
| } |
| if ($is_calls) |
| { |
| if (substr ($routine,0,1) eq "*") |
| { |
| $routine = substr ($routine,1); |
| } |
| } |
| for $vdso_key (keys %LINUX_vDSO) |
| { |
| if ($routine eq $LINUX_vDSO{$vdso_key}) |
| { |
| #------------------------------------------------------------------------------ |
| # presume no duplicates - at least can check offset |
| #------------------------------------------------------------------------------ |
| if ($vdso_key =~ /(\d+):(\S+)/) |
| #------------------------------------------------------------------------------ |
| # no -ve segments allowed and not expected |
| #------------------------------------------------------------------------------ |
| { |
| if ($2 eq $offset) |
| { |
| #------------------------------------------------------------------------------ |
| # the real segment |
| #------------------------------------------------------------------------------ |
| $segment = $1; |
| gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE"); |
| $PC_Address = $segment.":".$offset; # PC Addr. |
| gp_message ("debugXL", $subr_name, "vdso line ->$line"); |
| $line = $PC_Address.(' ' x (length ($spaces)-2)).$rest; |
| gp_message ("debugXL", $subr_name, "becomes ->$line"); |
| last; |
| } |
| } |
| } |
| } |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE"); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # a rotten exception for Linux vDSO |
| # With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file |
| # can have lines like |
| #->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<- |
| #->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<- |
| #->-1:0xff600000 99.040 0 0 [vsyscall]<- |
| # (Real PC Address: 4294967295:0xff600000) |
| #-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<- |
| #-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<- |
| # Rats! |
| # $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"}; |
| #------------------------------------------------------------------------------ |
| |
| $not_printed = $TRUE; |
| for $vdso_key (keys %LINUX_vDSO) |
| { |
| if ($line =~ /^(\s*)($vdso_key)(.*)$/) |
| { |
| $blanks = 1; |
| $rest = 3; |
| $lblanks = length ($blanks); |
| $lvdso_key = length ($vdso_key); |
| $PC_Address = $vdso_key; # PC Addr. |
| $offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key; |
| gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-"); |
| if ($pc_len) |
| { |
| print FUNC_FILE_NO_PC substr ($line,$offy)."\n"; |
| $not_printed = $FALSE; |
| } |
| else |
| { |
| die ("sod1a"); |
| } |
| gp_message ("debugXL", $subr_name, "vdso line ->$line"); |
| if (substr ($line,$lblanks+$lvdso_key,1) eq " ") |
| { |
| #------------------------------------------------------------------------------ |
| # O.K. no field abuttal |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line"); |
| } |
| else |
| { |
| gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line"); |
| $line = $blanks.$vdso_key." ".$rest; |
| } |
| gp_message ("debugXL", $subr_name, "becomes ->$line"); |
| last; |
| } |
| } |
| if ($not_printed) |
| { |
| if ($pc_len) |
| { |
| print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; |
| } |
| else |
| { |
| die ("sod1b"); |
| } |
| $not_printed = $FALSE; |
| } |
| } |
| else |
| { |
| if (!$pc_len) |
| { |
| if ($line =~ /(^\s*PC Addr.\s+)(\S+)/) |
| { |
| $pc_len = length ($1); # say 15 |
| print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; |
| } |
| else |
| { |
| print FUNC_FILE_NO_PC "$line\n"; |
| } |
| } |
| else |
| { |
| if ($pc_len) |
| { |
| my $strlen = length ($line); |
| if ($strlen > 0 ) |
| { |
| print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; |
| } |
| else |
| { |
| print FUNC_FILE_NO_PC "\n"; |
| } |
| } |
| else |
| { |
| die ("sod2"); |
| } |
| } |
| next; |
| } |
| $routine = ""; |
| if ($line =~ /$name_regex/) |
| { |
| if ($metric_ok) |
| { |
| $metric_value = $1; # whatever |
| $routine = $2; |
| } |
| else |
| { |
| $routine = $1; |
| } |
| } |
| |
| if ($is_calls) |
| { |
| if (substr ($routine,0,1) eq "*") |
| { |
| $routine = substr ($routine,1); |
| } |
| } |
| if (length ($routine)) |
| { |
| $order[$index_val]{"routine"} = $routine; |
| if ($metric_ok) |
| { |
| $order[$index_val]{"metric_value"} = $metric_value; |
| } |
| $order[$index_val]{"PC Address"} = $PC_Address; |
| $df_flag = 0; |
| if (not exists ($functions_per_metric_indexes{$routine})) |
| { |
| $functions_per_metric_indexes{$routine} = [$index_val]; |
| } |
| else |
| { |
| push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list |
| } |
| gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line"); |
| if ($PC_Address =~ /\s*(\S+):(\S+)/) |
| { |
| my ($segment,$offset); |
| $segment = $1; |
| $offset = $2; |
| $address_decimal = bigint::hex ($offset); # decimal |
| $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280 |
| $order[$index_val]{"addressobj"} = $address_decimal; |
| $order[$index_val]{"addressobjtext"} = $full_address_field; |
| } |
| #------------------------------------------------------------------------------ |
| # Check uniqueness |
| #------------------------------------------------------------------------------ |
| if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address})) |
| { |
| $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val; |
| $u++; #$RI |
| } |
| else |
| { |
| if (!($metric eq "calls" || $metric eq "calltree")) |
| { |
| gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address"); |
| } |
| } |
| |
| $index_val++; |
| gp_message ("debugXL", $subr_name, "updated index_val = $index_val"); |
| $n++; |
| next; |
| } |
| else |
| { |
| if ($n && length ($line)) |
| { |
| my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| } |
| } |
| close (FUNC_FILE); |
| close (FUNC_FILE_NO_PC); |
| |
| for my $i (sort keys %functions_per_metric_indexes) |
| { |
| my $values = ""; |
| for my $fields (sort keys @{ $functions_per_metric_indexes{$i} }) |
| { |
| $values .= "$functions_per_metric_indexes{$i}[$fields] "; |
| } |
| gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values"); |
| } |
| |
| return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes); |
| |
| } #-- End of subroutine function_info |
| |
| #------------------------------------------------------------------------------ |
| # Generate a html header. |
| #------------------------------------------------------------------------------ |
| sub generate_a_header |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($page_text_ref, $size_text_ref, $position_text_ref) = @_; |
| |
| my $page_text = ${ $page_text_ref }; |
| my $size_text = ${ $size_text_ref }; |
| my $position_text = ${ $position_text_ref }; |
| my $html_header; |
| |
| $html_header = "<div class=\"" . $position_text . "\">\n"; |
| $html_header .= "<". $size_text . ">\n"; |
| $html_header .= $page_text . "\n"; |
| $html_header .= "</". $size_text . ">\n"; |
| $html_header .= "</div>"; |
| |
| gp_message ("debugXL", $subr_name, "on exit page_title = $html_header"); |
| |
| return (\$html_header); |
| |
| } #-- End of subroutine generate_a_header |
| |
| #------------------------------------------------------------------------------ |
| # Generate the caller-callee information. |
| #------------------------------------------------------------------------------ |
| sub generate_caller_callee |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, |
| $function_address_info_ref, $addressobjtextm_ref, |
| $input_string_ref) = @_; |
| |
| my $number_of_metrics = ${ $number_of_metrics_ref }; |
| my @function_info = @{ $function_info_ref }; |
| my %function_view_structure = %{ $function_view_structure_ref }; |
| my %function_address_info = %{ $function_address_info_ref }; |
| my %addressobjtextm = %{ $addressobjtextm_ref }; |
| my $input_string = ${ $input_string_ref }; |
| |
| my @caller_callee_data = (); |
| my $outfile; |
| my $input_line; |
| |
| my $fullname; |
| my $separator = "cuthere"; |
| |
| my @address_field = (); |
| my @fields = (); |
| my @function_names = (); |
| my @marker = (); |
| my @metric_values = (); |
| my @word_index_values = (); |
| my @header_lines = (); |
| |
| my $all_metrics; |
| my $elements_in_name; |
| my $full_hex_address; |
| my $hex_address; |
| |
| my $file_title; |
| my $page_title; |
| my $size_text; |
| my $position_text; |
| my @html_metric_sort_header = (); |
| my $html_header; |
| my $html_title_header; |
| my $html_home; |
| my $html_acknowledgement; |
| my $html_end; |
| my $html_line; |
| |
| my $marker_target_function; |
| my $max_metrics_length = 0; |
| my $metrics_length; |
| my $modified_line; |
| my $name_regex; |
| my $no_of_fields; |
| my $routine; |
| my $routine_length; |
| my $string_length; |
| my $top_header; |
| my $total_header_lines; |
| my $word_index_values_ref; |
| my $infile; |
| |
| my $outputdir = append_forward_slash ($input_string); |
| my $LANG = $g_locale_settings{"LANG"}; |
| my $decimal_separator = $g_locale_settings{"decimal_separator"}; |
| |
| gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator"); |
| gp_message ("debug", $subr_name, "outputdir = $outputdir"); |
| |
| $infile = $outputdir . "caller-callee-PC2"; |
| $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html"; |
| |
| gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile"); |
| |
| open (CALLER_CALLEE_IN, "<", $infile) |
| or die ("unable to open caller file $infile for reading - '$!'"); |
| gp_message ("debug", $subr_name, "opened file $infile for reading"); |
| |
| open (CALLER_CALLEE_OUT, ">", $outfile) |
| or die ("unable to open $outfile for writing - '$!'"); |
| gp_message ("debug", $subr_name, "opened file $outfile for writing"); |
| |
| gp_message ("debug", $subr_name, "building caller-callee file $outfile"); |
| |
| #------------------------------------------------------------------------------ |
| # Generate some of the structures used in the HTML output. |
| #------------------------------------------------------------------------------ |
| $file_title = "Caller-callee overview"; |
| $html_header = ${ create_html_header (\$file_title) }; |
| $html_home = ${ generate_home_link ("right") }; |
| |
| $page_title = "Caller Callee View"; |
| $size_text = "h2"; |
| $position_text = "center"; |
| $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; |
| |
| #------------------------------------------------------------------------------ |
| # Read all of the file into array with the name caller_callee_data. |
| #------------------------------------------------------------------------------ |
| chomp (@caller_callee_data = <CALLER_CALLEE_IN>); |
| |
| #------------------------------------------------------------------------------ |
| # Typical structure of the input file: |
| # |
| # Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm |
| # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) |
| # Functions sorted by metric: Exclusive Total CPU Time |
| # Callers and callees sorted by metric: Attributed Total CPU Time |
| # |
| # PC Addr. Name Attr. Attr. CPU Attr. Attr. |
| # Total Cycles Instructions Last-Level |
| # CPU sec. sec. Executed Cache Misses |
| # 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250 |
| # 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045 |
| # 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205 |
| # |
| # PC Addr. Name Attr. Attr. CPU Attr. Attr. |
| # Total Cycles Instructions Last-Level |
| # CPU sec. sec. Executed Cache Misses |
| # 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045 |
| # 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045 |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Scan the input file. The first lines are assumed to be part of the header, |
| # so we store those. The diagnostic lines that echo some settings are also |
| # stored, but currently not used. |
| #------------------------------------------------------------------------------ |
| my $scan_header = $FALSE; |
| my $scan_caller_callee_data = $FALSE; |
| my $data_function_block = ""; |
| my @function_blocks = (); |
| my $first = $TRUE; |
| my @html_caller_callee = (); |
| my @top_level_header = (); |
| |
| #------------------------------------------------------------------------------ |
| # The regexes. |
| #------------------------------------------------------------------------------ |
| my $empty_line_regex = '^\s*$'; |
| my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)'; |
| my $get_hex_address_regex = '(\d+):0x(\S+)'; |
| my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)'; |
| my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; |
| my $sorted_by_regex = 'sorted by metric:'; |
| my $current_regex = '^Current'; |
| my $get_addr_offset_regex = '^@\d+:'; |
| |
| #------------------------------------------------------------------------------ |
| # Get the length of the first metric field across all lines. This value is |
| # used to pad the first metric with spaces and get the alignment right. |
| # |
| # Scan the input data and find the line(s) with metric values. A complication |
| # is that a function name may consists of more than one field. |
| # |
| # Note. This part could be used to parse the other elements of the input file, |
| # but that makes the loop very complicated. Instead, we re-scan the data |
| # below and process each block separately. |
| # |
| # Since this data is all in memory and relatively small, the performance should |
| # not suffer much, but it does improve the readability of the code. |
| #------------------------------------------------------------------------------ |
| gp_message ("debug", $subr_name, "determine the maximum length of the first field"); |
| |
| $g_max_length_first_metric = 0; |
| my @hex_addresses = (); |
| my @special_marker = (); |
| my @the_function_name = (); |
| my @the_metrics = (); |
| my @length_first_metric = (); |
| |
| for (my $line = 0; $line <= $#caller_callee_data; $line++) |
| { |
| my $input_line = $caller_callee_data[$line]; |
| |
| if ($input_line =~ /$line_of_interest_regex/) |
| { |
| if (defined ($1) and defined ($2) and defined ($3)) |
| #------------------------------------------------------------------------------ |
| # This is a line of interest, since it has the address, the function name and |
| # the values for the metrics. Examples of valid lines are: |
| # |
| # 2:0x00005028 *xfree_large 0. 0 |
| # 12:0x0004c2b0 munmap 0.143 6402086 |
| # 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0 |
| # |
| # The function name marked with a * is the current target. |
| #------------------------------------------------------------------------------ |
| { |
| my $full_hex_address = $1; |
| my $marker = $2; |
| my $remaining_line = $3; |
| |
| if ($full_hex_address =~ /$get_hex_address_regex/) |
| { |
| $hex_address = "0x" . $2; |
| push (@hex_addresses, $hex_address); |
| gp_message ("debugXL", $subr_name, "pushed $hex_address"); |
| } |
| else |
| { |
| my $msg = "full_hex_address = $full_hex_address has an unknown format"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| if ($marker eq "*") |
| { |
| push (@special_marker, "*"); |
| } |
| else |
| { |
| push (@special_marker, "X"); |
| } |
| } |
| else |
| { |
| my $msg = "input_line = $input_line has an unknown format"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| my @fields_in_line = split (" ", $input_line); |
| |
| #------------------------------------------------------------------------------ |
| # We stripped the address and marker (if any), off, so this string starts with |
| # the function name. |
| #------------------------------------------------------------------------------ |
| my $remainder = $3; |
| my $number_of_fields = scalar (@fields_in_line); |
| my $words_in_function_name = $number_of_fields - $number_of_metrics - 1; |
| my @remainder_array = split (" ", $remainder); |
| |
| #------------------------------------------------------------------------------ |
| # If the first metric is 0. (or 0, depending on the locale), the calculation |
| # of the length needs to be adjusted, because 0. is really 0.000. |
| # |
| # While we could easily add 3 to the length, we assign a symbolic value to the |
| # first metric (ZZZ) and then compute the length. This makes things clearer. |
| # I hope ;-) |
| #------------------------------------------------------------------------------ |
| my $first_metric = $remainder_array[$words_in_function_name]; |
| if ($first_metric =~ /^0$decimal_separator$/) |
| { |
| gp_message ("debugXL", $subr_name, "fixed up $first_metric"); |
| $first_metric = "0.ZZZ"; |
| } |
| push (@length_first_metric, length ($first_metric)); |
| |
| my $txt = "words in function name = $words_in_function_name "; |
| $txt .= "first_metric = $first_metric length = "; |
| $txt .= length ($first_metric); |
| gp_message ("debugXL", $subr_name, $txt); |
| |
| #------------------------------------------------------------------------------ |
| # Generate the regex for the metrics. |
| # |
| # TBD: This should be an attribute of the function and be done once only. |
| #------------------------------------------------------------------------------ |
| my $m_regex = '(\S+'; |
| for my $f (2 .. $words_in_function_name) |
| { |
| $m_regex .= '\s+\S+'; |
| } |
| #------------------------------------------------------------------------------ |
| # This last part captures all the metric values. |
| #------------------------------------------------------------------------------ |
| $m_regex .= $get_metric_field_regex; |
| gp_message ("debugXL", $subr_name, "m_regex = $m_regex"); |
| gp_message ("debugXL", $subr_name, "remainder = $remainder"); |
| |
| if ($remainder =~ /$m_regex/) |
| { |
| my $func_name = $1; |
| my $its_metrics = $2; |
| my $msg = "found the info - func_name = " . $func_name . |
| " its metrics = " . $its_metrics; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| push (@the_function_name, $func_name); |
| push (@the_metrics, $its_metrics); |
| } |
| else |
| { |
| my $msg = "remainder string $remainder has an unrecognized format"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| $g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric)); |
| |
| my $msg = "first_metric = $first_metric " . |
| "g_max_length_first_metric = $g_max_length_first_metric"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| } |
| gp_message ("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric"); |
| gp_message ("debugXL", $subr_name, "#hex_addresses = $#hex_addresses"); |
| |
| #------------------------------------------------------------------------------ |
| # Main loop over the input data. |
| #------------------------------------------------------------------------------ |
| my $index_start = 0; # 1 |
| my $index_end = -1; # 0 |
| for (my $line = 0; $line <= $#caller_callee_data; $line++) |
| { |
| my $input_line = $caller_callee_data[$line]; |
| |
| if ($input_line =~ /$header_name_regex/) |
| { |
| $scan_header = $TRUE; |
| gp_message ("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first"); |
| } |
| elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/)) |
| { |
| my $msg = "line = " . $line . " captured top level header: " . |
| "input_line = " . $input_line; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| push (@top_level_header, $input_line); |
| } |
| elsif ($input_line =~ /$line_of_interest_regex/) |
| { |
| $index_end++; |
| $scan_header = $FALSE; |
| $scan_caller_callee_data = $TRUE; |
| $data_function_block .= $separator . $input_line; |
| |
| my $msg = "line = $line updated index_end = $index_end"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data)) |
| { |
| #------------------------------------------------------------------------------ |
| # An empty line is interpreted as the end of the current block and we process |
| # this, including the generation of the html code for this block. |
| #------------------------------------------------------------------------------ |
| $first = $FALSE; |
| $scan_caller_callee_data = $FALSE; |
| |
| gp_message ("debugXL", $subr_name, "new block"); |
| gp_message ("debugXL", $subr_name, "line = $line index_start = $index_start"); |
| gp_message ("debugXL", $subr_name, "line = $line index_end = $index_end"); |
| gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block"); |
| |
| push (@function_blocks, $data_function_block); |
| my ($html_block_prologue_ref, $html_code_function_block_ref) = |
| generate_html_function_blocks ( |
| \$index_start, |
| \$index_end, |
| \@hex_addresses, |
| \@the_metrics, |
| \@length_first_metric, |
| \@special_marker, |
| \@the_function_name, |
| \$separator, |
| $number_of_metrics_ref, |
| \$data_function_block, |
| $function_info_ref, |
| $function_view_structure_ref); |
| |
| my @html_block_prologue = @{ $html_block_prologue_ref }; |
| my @html_code_function_block = @{ $html_code_function_block_ref }; |
| |
| for my $lines (0 .. $#html_code_function_block) |
| { |
| my $msg = "final html_code_function_block[" . $lines . "] = " . |
| $html_code_function_block[$lines]; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| |
| $data_function_block = ""; |
| |
| push (@html_caller_callee, @html_block_prologue); |
| push (@html_caller_callee, @header_lines); |
| push (@html_caller_callee, @html_code_function_block); |
| |
| $index_start = $index_end + 1; |
| $index_end = $index_start - 1; |
| gp_message ("debugXL", $subr_name, "line = $line reset index_start = $index_start"); |
| gp_message ("debugXL", $subr_name, "line = $line reset index_end = $index_end"); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Only capture the first header. They are all identical. |
| #------------------------------------------------------------------------------ |
| if ($scan_header and $first) |
| { |
| if (defined ($4)) |
| { |
| #------------------------------------------------------------------------------ |
| # This group is only defined for the first line of the header. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "header1 = $4"); |
| gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x"); |
| my $newline = "<b>" . $4 . "</b>"; |
| push (@header_lines, $newline); |
| } |
| elsif ($input_line =~ /\s*(.*)/) |
| { |
| #------------------------------------------------------------------------------ |
| # Capture the subsequent header lines. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "headern = $1"); |
| my $newline = "<b>" . $1 . "</b>"; |
| push (@header_lines, $newline); |
| } |
| } |
| |
| } |
| |
| for my $i (0 .. $#header_lines) |
| { |
| gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); |
| } |
| for my $i (0 .. $#function_blocks) |
| { |
| gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]"); |
| } |
| |
| my $number_of_blocks = $#function_blocks + 1; |
| gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:"); |
| |
| for my $i (0 .. $#function_blocks) |
| { |
| #------------------------------------------------------------------------------ |
| # The split produces an empty first field and is why we skip the first field. |
| #------------------------------------------------------------------------------ |
| ## my @entries = split ("cuthere", $function_blocks[$i]); |
| my @entries = split ($separator, $function_blocks[$i]); |
| for my $k (1 .. $#entries) |
| { |
| my $msg = "entries[" . $k . "] = ". $entries[$k]; |
| gp_message ("debugXL", $subr_name, $k . $msg); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Parse and process the individual function blocks. |
| #------------------------------------------------------------------------------ |
| for my $i (0 .. $#function_blocks) |
| { |
| my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i]; |
| gp_message ("debugXL", $subr_name, $msg); |
| #------------------------------------------------------------------------------ |
| # This split produces an empty first field. This is why skip this. |
| #------------------------------------------------------------------------------ |
| my @entries = split ($separator, $function_blocks[$i]); |
| |
| #------------------------------------------------------------------------------ |
| # An example of @entries: |
| # <empty> |
| # 6:0x0003ad20 drand48 0.100 0.084 768240570 0 |
| # 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 |
| # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 |
| #------------------------------------------------------------------------------ |
| for my $k (1 .. $#entries) |
| { |
| my $input_line = $entries[$k]; |
| |
| my $msg = "input_line = entries[" . $k . "] = ". $entries[$k]; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| @fields = split (" ", $input_line); |
| |
| $no_of_fields = $#fields + 1; |
| $elements_in_name = $no_of_fields - $number_of_metrics - 1; |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Too restrictive. |
| # CHECK CODE IN GENERATE_CALLER_CALLEE |
| #------------------------------------------------------------------------------ |
| if ($elements_in_name == 1) |
| { |
| $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)'; |
| } |
| elsif ($elements_in_name == 2) |
| { |
| $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)'; |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # TBD: Handle this better in case a function entry has more than 2 words. |
| #------------------------------------------------------------------------------ |
| { |
| my $msg = "$elements_in_name elements in name exceeds limit"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| if ($input_line =~ /$name_regex/) |
| { |
| $full_hex_address = $1; |
| $marker_target_function = $2; |
| $routine = $3; |
| if ($elements_in_name == 1) |
| { |
| $all_metrics = $4; |
| } |
| elsif ($elements_in_name == 2) |
| { |
| $all_metrics = $6; |
| } |
| |
| $metrics_length = length ($all_metrics); |
| $max_metrics_length = max ($max_metrics_length, $metrics_length); |
| |
| if ($full_hex_address =~ /(\d+):0x(\S+)/) |
| { |
| $hex_address = "0x" . $2; |
| } |
| push (@marker, $marker_target_function); |
| push (@address_field, $hex_address); |
| $modified_line = $all_metrics . " " . $routine; |
| push (@metric_values, $all_metrics); |
| gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); |
| push (@function_names, $routine); |
| } |
| } |
| |
| $total_header_lines = $#header_lines + 1; |
| gp_message ("debugXL", $subr_name, "total_header_lines = $total_header_lines"); |
| |
| gp_message ("debugXL", $subr_name, "Final output"); |
| for my $i (keys @header_lines) |
| { |
| gp_message ("debugXL", $subr_name, "$header_lines[$i]"); |
| } |
| for my $i (0 .. $#function_names) |
| { |
| my $msg = $metric_values[$i] . " " . $marker[$i] . |
| $function_names[$i] . "(" . $address_field[$i] . ")"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| #------------------------------------------------------------------------------ |
| # Check if this function has multiple occurrences. |
| # TBD: Replace by the function call for this. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "check for multiple occurrences"); |
| for my $i (0 .. $#function_names) |
| { |
| my $current_address = $address_field[$i]; |
| my $found_a_match; |
| my $ref_index; |
| my $alt_name; |
| $routine = $function_names[$i]; |
| $alt_name = $routine; |
| gp_message ("debugXL", $subr_name, "checking for routine = $routine"); |
| if (exists ($g_multi_count_function{$routine})) |
| { |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! |
| #------------------------------------------------------------------------------ |
| |
| $found_a_match = $FALSE; |
| gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); |
| for my $ref (keys @{ $g_map_function_to_index{$routine} }) |
| { |
| $ref_index = $g_map_function_to_index{$routine}[$ref]; |
| |
| gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); |
| gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); |
| |
| my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; |
| gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); |
| |
| $addr_offset =~ s/$get_addr_offset_regex//; |
| gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); |
| if ($addr_offset eq $current_address) |
| { |
| $found_a_match = $TRUE; |
| last; |
| } |
| } |
| gp_message ("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match"); |
| $alt_name = $function_info[$ref_index]{'alt_name'}; |
| } |
| gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); |
| } |
| gp_message ("debugXL", $subr_name, "completed check for multiple occurrences"); |
| |
| #------------------------------------------------------------------------------ |
| # Figure out the column width. Since the columns in the header may include |
| # spaces, we use the first line with metrics for this. |
| #------------------------------------------------------------------------------ |
| my $top_header = $metric_values[0]; |
| my $word_index_values_ref = find_words_in_line (\$top_header); |
| my @word_index_values = @{ $word_index_values_ref }; |
| |
| # $i = 0 0 4 |
| # $i = 1 10 14 |
| # $i = 2 21 31 |
| # $i = 3 35 42 |
| for my $i (keys @word_index_values) |
| { |
| gp_message ("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]"); |
| } |
| } |
| |
| push (@html_metric_sort_header, "<i>"); |
| for my $i (0 .. $#top_level_header) |
| { |
| $html_line = $top_level_header[$i] . "<br>"; |
| push (@html_metric_sort_header, $html_line); |
| } |
| push (@html_metric_sort_header, "</i>"); |
| |
| print CALLER_CALLEE_OUT $html_header; |
| print CALLER_CALLEE_OUT $html_home; |
| print CALLER_CALLEE_OUT $html_title_header; |
| print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats; |
| ## print CALLER_CALLEE_OUT "<br>\n"; |
| ## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header; |
| print CALLER_CALLEE_OUT "<pre>\n"; |
| print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee; |
| print CALLER_CALLEE_OUT "</pre>\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Get the acknowledgement, return to main link, and final html statements. |
| #------------------------------------------------------------------------------ |
| $html_home = ${ generate_home_link ("left") }; |
| $html_acknowledgement = ${ create_html_credits () }; |
| $html_end = ${ terminate_html_document () }; |
| |
| print CALLER_CALLEE_OUT $html_home; |
| print CALLER_CALLEE_OUT "<br>\n"; |
| print CALLER_CALLEE_OUT $html_acknowledgement; |
| print CALLER_CALLEE_OUT $html_end; |
| |
| close (CALLER_CALLEE_OUT); |
| |
| return (0); |
| |
| } #-- End of subroutine generate_caller_callee |
| |
| #------------------------------------------------------------------------------ |
| # Generate the html version of the disassembly file. |
| # |
| # Note to self (TBD) |
| # https://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 $script_pc_metrics; |
| |
| my $outputdir = append_forward_slash ($input_string); |
| |
| my $script_file_PC = $outputdir."gp-script-PC"; |
| my $result_file = $outputdir."gp-out-PC.err"; |
| my $gp_error_file = $outputdir."gp-out-PC.err"; |
| my $func_limit = $g_user_settings{func_limit}{current_value}; |
| |
| #------------------------------------------------------------------------------ |
| # The number of entries in the Function Overview includes <Total>, but that is |
| # not a concern to the user and we add "1" to compensate for this. |
| #------------------------------------------------------------------------------ |
| $func_limit += 1; |
| |
| gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit"); |
| |
| $expr_name = join (" ", @exp_dir_list); |
| |
| gp_message ("debug", $subr_name, "expr_name = $expr_name"); |
| |
| for my $i (0 .. $#sort_fields) |
| { |
| gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]"); |
| } |
| |
| # Ruud $count = 0; |
| |
| gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files"); |
| |
| open (SCRIPT_PC, ">", $script_file_PC) |
| or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $script_file_PC for writing"); |
| |
| #------------------------------------------------------------------------------ |
| # Get the list of functions. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Get the first metric. |
| #------------------------------------------------------------------------------ |
| $summary_metrics =~ /^([^:]+)/; |
| $first_metric = $1; |
| $g_first_metric = $1; |
| $script_pc_metrics = "address:$summary_metrics"; |
| |
| gp_message ("debugXL", $subr_name, "$func_limit"); |
| gp_message ("debugXL", $subr_name, "$summary_metrics"); |
| gp_message ("debugXL", $subr_name, "$first_metric"); |
| gp_message ("debugXL", $subr_name, "$script_pc_metrics"); |
| |
| # Temporarily disabled print SCRIPT_PC "# limit $func_limit\n"; |
| # Temporarily disabled print SCRIPT_PC "limit $func_limit\n"; |
| print SCRIPT_PC "# thread_select all\n"; |
| print SCRIPT_PC "thread_select all\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Empty header. |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."header\n"; |
| print SCRIPT_PC "outfile $outputdir"."header\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Else the output from the next line goes to last sort.func |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; |
| print SCRIPT_PC "# metrics $script_pc_metrics\n"; |
| print SCRIPT_PC "metrics $script_pc_metrics\n"; |
| #------------------------------------------------------------------------------ |
| # Not really sorted |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; |
| print SCRIPT_PC "# functions\n"; |
| print SCRIPT_PC "functions\n"; |
| |
| print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; |
| print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; |
| print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "# sort $first_metric\n"; |
| print SCRIPT_PC "sort $first_metric\n"; |
| print SCRIPT_PC "# functions\n"; |
| print SCRIPT_PC "functions\n"; |
| #------------------------------------------------------------------------------ |
| # Go through all the possible metrics and sort by each of them. |
| #------------------------------------------------------------------------------ |
| for my $field (@sort_fields) |
| { |
| gp_message ("debug", $subr_name, "sort_fields field = $field"); |
| #------------------------------------------------------------------------------ |
| # Else the output from the next line goes to last sort.func |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; |
| print SCRIPT_PC "# metrics $script_pc_metrics\n"; |
| print SCRIPT_PC "metrics $script_pc_metrics\n"; |
| print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n"; |
| print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n"; |
| print SCRIPT_PC "# sort $field\n"; |
| print SCRIPT_PC "sort $field\n"; |
| print SCRIPT_PC "# functions\n"; |
| print SCRIPT_PC "functions\n"; |
| |
| print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n"; |
| print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n"; |
| print SCRIPT_PC "# sort $field\n"; |
| print SCRIPT_PC "sort $field\n"; |
| print SCRIPT_PC "# functions\n"; |
| print SCRIPT_PC "functions\n"; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Get caller-callee list |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n"; |
| print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n"; |
| print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "metrics address:name:$summary_metrics\n"; |
| print SCRIPT_PC "# callers-callees\n"; |
| print SCRIPT_PC "callers-callees\n"; |
| #------------------------------------------------------------------------------ |
| # Else the output from the next line goes to last sort.func |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; |
| $script_pc_metrics = "address:$call_metrics"; |
| print SCRIPT_PC "# metrics $script_pc_metrics\n"; |
| print SCRIPT_PC "metrics $script_pc_metrics\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Not really sorted |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Get caller-callee list |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# callers-callees\n"; |
| print SCRIPT_PC "callers-callees\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Else the output from the next line goes to last sort.func |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n"; |
| print SCRIPT_PC "# metrics $script_pc_metrics\n"; |
| print SCRIPT_PC "metrics $script_pc_metrics\n"; |
| |
| if ($g_user_settings{"calltree"}{"current_value"} eq "on") |
| { |
| gp_message ("verbose", $subr_name, "Generate the file with the calltree information"); |
| #------------------------------------------------------------------------------ |
| # Get calltree list |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n"; |
| print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n"; |
| print SCRIPT_PC "# calltree\n"; |
| print SCRIPT_PC "calltree\n"; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Get the default set of metrics |
| #------------------------------------------------------------------------------ |
| my $full_metrics_ref; |
| my $all_metrics; |
| my $full_function_view = $outputdir . "functions.full"; |
| |
| $full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir); |
| |
| $all_metrics = "address:name:"; |
| $all_metrics .= ${$full_metrics_ref}; |
| gp_message ("debug", $subr_name, "all_metrics = $all_metrics"); |
| #------------------------------------------------------------------------------ |
| # Get the name, address, and full overview of all metrics for all functions |
| #------------------------------------------------------------------------------ |
| print SCRIPT_PC "# limit 0\n"; |
| print SCRIPT_PC "limit 0\n"; |
| print SCRIPT_PC "# metrics $all_metrics\n"; |
| print SCRIPT_PC "metrics $all_metrics\n"; |
| print SCRIPT_PC "# thread_select all\n"; |
| print SCRIPT_PC "thread_select all\n"; |
| print SCRIPT_PC "# sort default\n"; |
| print SCRIPT_PC "sort default\n"; |
| print SCRIPT_PC "# outfile $full_function_view\n"; |
| print SCRIPT_PC "outfile $full_function_view\n"; |
| print SCRIPT_PC "# functions\n"; |
| print SCRIPT_PC "functions\n"; |
| |
| close (SCRIPT_PC); |
| |
| $result_file = $outputdir."gp-out-PC.err"; |
| $gp_error_file = $outputdir.$g_gp_error_logfile; |
| |
| $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit "; |
| $gp_functions_cmd .= "-viewmode machine -compare off "; |
| $gp_functions_cmd .= "-script $script_file_PC $expr_name"; |
| |
| gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information"); |
| |
| $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; |
| |
| gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd"); |
| |
| my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); |
| |
| if ($error_code != 0) |
| { |
| $ignore_value = msg_display_text_failure ($gp_display_text_cmd, |
| $error_code, |
| $gp_error_file); |
| gp_message ("abort", $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]; |
| |
| # 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 $whatever; |
| my $df_flag; |
| my $address_decimal; |
| my $routine; |
| |
| my $num_source_files = 0; |
| my $number_of_functions = 0; |
| my $number_of_unique_functions = 0; |
| my $number_of_non_unique_functions = 0; |
| |
| #------------------------------------------------------------------------------ |
| # Open the file generated using the -fsummary option. |
| #------------------------------------------------------------------------------ |
| open (FSUMMARY_FILE, "<", $FSUMMARY_FILE) |
| or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $FSUMMARY_FILE for reading"); |
| |
| #------------------------------------------------------------------------------ |
| # This is the typical structure of the fsummary output: |
| # |
| # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) |
| # Functions sorted by metric: Exclusive Total CPU Time |
| # |
| # <Total> |
| # Exclusive Total CPU Time: 11.538 (100.0%) |
| # Inclusive Total CPU Time: 11.538 (100.0%) |
| # Size: 0 |
| # PC Address: 1:0x00000000 |
| # Source File: (unknown) |
| # Object File: (unknown) |
| # Load Object: <Total> |
| # Mangled Name: |
| # Aliases: |
| # |
| # a_function_name |
| # Exclusive Total CPU Time: 4.003 ( 34.7%) |
| # Inclusive Total CPU Time: 4.003 ( 34.7%) |
| # Size: 715 |
| # PC Address: 2:0x00006c61 |
| # Source File: <absolute path to source file> |
| # Object File: <object filename> |
| # Load Object: <executable name> |
| # Mangled Name: |
| # Aliases: |
| # |
| # The previous block is repeated for every function. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Skip the header. The header is defined to end with a blank line. |
| #------------------------------------------------------------------------------ |
| while (<FSUMMARY_FILE>) |
| { |
| $line = $_; |
| chomp ($line); |
| if ($line =~ /^\s*$/) |
| { |
| last; |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Process the remaining blocks. Note that the first line should be <Total>, |
| # but this is currently not checked. |
| #------------------------------------------------------------------------------ |
| $i = 0; |
| $routine_flag = $TRUE; |
| while (<FSUMMARY_FILE>) |
| { |
| $line = $_; |
| chomp ($line); |
| gp_message ("debugXL", $subr_name, "line = $line"); |
| |
| if ($line =~ /^\s*$/) |
| #------------------------------------------------------------------------------ |
| # Blank line. |
| #------------------------------------------------------------------------------ |
| { |
| $routine_flag = $TRUE; |
| $df_flag = 0; |
| |
| #------------------------------------------------------------------------------ |
| # Linux vDSO exception |
| # |
| # TBD: Check if still relevant. |
| #------------------------------------------------------------------------------ |
| if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS") |
| { |
| $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"}; |
| } |
| $i++; |
| next; |
| } |
| |
| if ($routine_flag) |
| #------------------------------------------------------------------------------ |
| # Should be the first line after the blank line. |
| #------------------------------------------------------------------------------ |
| { |
| $routine = $line; |
| push (@{ $g_map_function_to_index{$routine} }, $i); |
| gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}"); |
| |
| #------------------------------------------------------------------------------ |
| # In a later parsing phase we need to know how many fields there are in a |
| # function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that |
| # may show up in a function list. |
| # |
| # Here we determine the number of fields and store it. |
| #------------------------------------------------------------------------------ |
| my @fields_in_name = split (" ", $routine); |
| $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name); |
| |
| #------------------------------------------------------------------------------ |
| # This name may change if the function has multiple occurrences, but in any |
| # case, at the end of this routine this component has the final name to be |
| # used. |
| #------------------------------------------------------------------------------ |
| $function_info[$i]{"alt_name"} = $routine; |
| if (not exists ($g_function_occurrences{$routine})) |
| { |
| gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist"); |
| $function_info[$i]{"routine"} = $routine; |
| $g_function_occurrences{$routine} = 1; |
| |
| gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}"); |
| } |
| else |
| { |
| gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already"); |
| $function_info[$i]{"routine"} = $routine; |
| $g_function_occurrences{$routine} += 1; |
| if (not exists ($g_multi_count_function{$routine})) |
| { |
| $g_multi_count_function{$routine} = $TRUE; |
| } |
| $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; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Expected format of an input line: |
| # Exclusive Total CPU Time: 4.003 ( 34.7%) |
| # or: |
| # Source File: <absolute_path>/name_of_source_file |
| #------------------------------------------------------------------------------ |
| $line =~ s/^\s+//; |
| |
| my @input_fields = split (":", $line); |
| my $no_of_elements = scalar (@input_fields); |
| |
| gp_message ("debugXL", $subr_name, "#input_fields = $#input_fields"); |
| gp_message ("debugXL", $subr_name, "no_of_elements = $no_of_elements"); |
| gp_message ("debugXL", $subr_name, "input_fields[0] = $input_fields[0]"); |
| |
| if ($no_of_elements == 1) |
| { |
| $whatever = $input_fields[0]; |
| $value = ""; |
| } |
| elsif ($no_of_elements == 2) |
| { |
| #------------------------------------------------------------------------------ |
| # Note that value may consist of multiple fields (e.g. 1.651 ( 95.4%)). |
| #------------------------------------------------------------------------------ |
| $whatever = $input_fields[0]; |
| $value = $input_fields[1]; |
| } |
| elsif ($no_of_elements == 3) |
| { |
| #------------------------------------------------------------------------------ |
| # Assumption: must be an address field. Restore the second colon. |
| #------------------------------------------------------------------------------ |
| $whatever = $input_fields[0]; |
| $value = $input_fields[1] . ":" . $input_fields[2]; |
| } |
| else |
| { |
| $msg = "unexpected: number of fields = " . $no_of_elements; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| #------------------------------------------------------------------------------ |
| # Remove any leading whitespace characters. |
| #------------------------------------------------------------------------------ |
| $value =~ s/$white_space_regex//; |
| |
| gp_message ("debugXL", $subr_name, "whatever = $whatever value = $value"); |
| |
| $function_info[$i]{$whatever} = $value; |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Seems to be not used anymore and can most likely be removed. Check this. |
| #------------------------------------------------------------------------------ |
| if ($whatever =~ /Source File/) |
| { |
| if (!exists ($source_files{$value})) |
| { |
| $source_files{$value} = $TRUE; |
| $num_source_files++; |
| } |
| } |
| |
| if ($whatever =~ /PC Address/) |
| { |
| my $segment; |
| my $offset; |
| #------------------------------------------------------------------------------ |
| # The format of the address is assumed to be the following 2:0x000070a8 |
| # Note that the regex is pretty wide. This is from the original code and |
| # could be made more specific: |
| # if ($value =~ /\s*(\S+):(\S+)/) |
| #------------------------------------------------------------------------------ |
| # if ($value =~ /\s*(\S+):(\S+)/) |
| if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/) |
| { |
| $segment = $1; |
| $offset = $2; |
| #------------------------------------------------------------------------------ |
| # Convert to a base 10 number |
| #------------------------------------------------------------------------------ |
| $address_decimal = bigint::hex ($offset); # decimal |
| #------------------------------------------------------------------------------ |
| # Construct the address field. Note that we use the hex address here. |
| # 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); |
| } |
| |
| $number_of_functions++; |
| } |
| } |
| close (FSUMMARY_FILE); |
| |
| #------------------------------------------------------------------------------ |
| # For every function in the function overview, set up an html structure with |
| # the various hyperlinks. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "augment function_info with alt_name"); |
| my $target_function; |
| my $html_line; |
| my $ftag; |
| my $routine_length; |
| my %html_source_functions = (); |
| for my $i (keys @function_info) |
| { |
| $target_function = $function_info[$i]{"routine"}; |
| |
| gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function"); |
| |
| my $href_link; |
| ## $href_link = "<a href=\'file." . $i . ".src.new.html#"; |
| $href_link = "<a href=\'file." . $i . "."; |
| $href_link .= $g_html_base_file_name{"source"}; |
| $href_link .= ".html#"; |
| $href_link .= $function_info[$i]{"tag_id"}; |
| $href_link .= "\'>source</a>"; |
| $function_info[$i]{"href_source"} = $href_link; |
| |
| $href_link = "<a href=\'file." . $i . "."; |
| $href_link .= $g_html_base_file_name{"disassembly"}; |
| $href_link .= ".html#"; |
| $href_link .= $function_info[$i]{"tag_id"}; |
| $href_link .= "\'>disassembly</a>"; |
| $function_info[$i]{"href_disassembly"} = $href_link; |
| |
| $href_link = "<a href=\'"; |
| $href_link .= $g_html_base_file_name{"caller_callee"}; |
| $href_link .= ".html#"; |
| $href_link .= $function_info[$i]{"tag_id"}; |
| $href_link .= "\'>caller-callee</a>"; |
| $function_info[$i]{"href_caller_callee"} = $href_link; |
| |
| gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}"); |
| |
| if ($g_function_occurrences{$target_function} > 1) |
| { |
| #------------------------------------------------------------------------------ |
| # In case a function occurs more than one time in the function overview, we |
| # add the load object and address offset info to make it unique. |
| # |
| # This forces us to update some entries in function_info too. |
| #------------------------------------------------------------------------------ |
| my $loadobj = $function_info[$i]{"Load Object"}; |
| my $address_field = $function_info[$i]{"addressobjtext"}; |
| my $address_offset; |
| |
| #------------------------------------------------------------------------------ |
| # The address field has the following format: @<n>:<address_offset> |
| # We only care about the address offset. |
| #------------------------------------------------------------------------------ |
| if ($address_field =~ /(^@\d*:*)(.+)/) |
| { |
| $address_offset = $2; |
| } |
| else |
| { |
| my $msg = "failed to extract the address offset from $address_field - use the full field"; |
| gp_message ("warning", $subr_name, $msg); |
| $address_offset = $address_field; |
| } |
| my $exe = get_basename ($loadobj); |
| my $extra_field = " (<" . $exe . " $address_offset" .">)"; |
| ### $target_function .= $extra_field; |
| $function_info[$i]{"alt_name"} = $target_function . $extra_field; |
| gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"}); |
| |
| #------------------------------------------------------------------------------ |
| # Store the length of the function name and get the tag id. |
| #------------------------------------------------------------------------------ |
| $function_info[$i]{"function length"} = length ($target_function . $extra_field); |
| $function_info[$i]{"tag_id"} = create_function_tag ($i); |
| |
| gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}"); |
| gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); |
| gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}"); |
| gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}"); |
| } |
| } |
| gp_message ("debug", $subr_name, "augment function_info with alt_name completed"); |
| |
| #------------------------------------------------------------------------------ |
| # Compute the maximum function name length. |
| # |
| # The maximum length is stored in %function_view_structure. |
| #------------------------------------------------------------------------------ |
| my $max_function_length = 0; |
| for my $i (0 .. $#function_info) |
| { |
| $max_function_length = 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 in 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: $number_of_functions"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "Number of functions functions with a unique name : " . |
| $number_of_unique_functions; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "Number of functions functions with more than one occurrence : " . |
| $number_of_non_unique_functions; |
| gp_message ("debug", $subr_name, $msg); |
| my $multi_occurrences = $number_of_functions - $number_of_unique_functions; |
| $msg = "Total number of multiple occurences of the same function name : " . |
| $multi_occurrences; |
| gp_message ("debug", $subr_name, $msg); |
| |
| return (\@function_info, \%function_address_and_index, \%addressobjtextm, |
| \%LINUX_vDSO, \%function_view_structure); |
| |
| } #-- End of subroutine get_function_info |
| #------------------------------------------------------------------------------ |
| # TBD |
| #------------------------------------------------------------------------------ |
| sub get_hdr_info |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($outputdir, $file) = @_; |
| |
| state $first_call = $TRUE; |
| |
| my $ASORTFILE; |
| my @HDR; |
| my $HDR; |
| my $metric; |
| my $line; |
| my $ignore_directory; |
| my $ignore_suffix; |
| my $number_of_header_lines; |
| |
| #------------------------------------------------------------------------------ |
| # Add a "/" to simplify the construction of path names in the remainder. |
| #------------------------------------------------------------------------------ |
| $outputdir = append_forward_slash ($outputdir); |
| |
| # Could get more header info from |
| # <metric>[e.bit_fcount].sort.func file - etc. |
| |
| gp_message ("debug", $subr_name, "input file->$file<-"); |
| #----------------------------------------------- |
| if ($file eq $outputdir."calls.sort.func") |
| { |
| $ASORTFILE=$outputdir."calls"; |
| $metric = "calls" |
| } |
| elsif ($file eq $outputdir."calltree.sort.func") |
| { |
| $ASORTFILE=$outputdir."calltree"; |
| $metric = "calltree" |
| } |
| elsif ($file eq $outputdir."functions.sort.func") |
| { |
| $ASORTFILE=$outputdir."functions.func"; |
| $metric = "functions"; |
| } |
| else |
| { |
| $ASORTFILE = $file; |
| # $metric = basename ($file,".sort.func"); |
| ($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func"); |
| gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix"); |
| } |
| |
| gp_message ("debug", $subr_name, "file = $file metric = $metric"); |
| |
| open (ASORTFILE,"<", $ASORTFILE) |
| or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading"); |
| |
| $number_of_header_lines = 0; |
| while (<ASORTFILE>) |
| { |
| $line =$_; |
| chomp ($line); |
| |
| if ($line =~ /^Current/) |
| { |
| next; |
| } |
| if ($line =~ /^Functions/) |
| { |
| next; |
| } |
| if ($line =~ /^Callers/) |
| { |
| next; |
| } |
| if ($line =~ /^\s*$/) |
| { |
| next; |
| } |
| if (!($line =~ /^\s*\d/)) |
| { |
| $HDR[$number_of_header_lines] = $line; |
| $number_of_header_lines++; |
| next; |
| } |
| last; |
| } |
| close (ASORTFILE); |
| #------------------------------------------------------------------------------ |
| # Ruud - Fixed a bug. The output should not be appended, but overwritten. |
| # open (HI,">>$OUTPUTDIR"."hdrinfo"); |
| #------------------------------------------------------------------------------ |
| my $outfile = $outputdir."hdrinfo"; |
| |
| if ($first_call) |
| { |
| $first_call = $FALSE; |
| open (HI ,">", $outfile) |
| or die ("$subr_name - unable to open file $outfile for writing: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $outfile for writing"); |
| } |
| else |
| { |
| open (HI ,">>", $outfile) |
| or die ("$subr_name - unable to open file $outfile in append mode: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $outfile in append mode"); |
| } |
| |
| print HI "\#$metric hdrlines=$number_of_header_lines\n"; |
| my $len = 0; |
| for $HDR (@HDR) |
| { |
| print HI "$HDR\n"; |
| gp_message ("debugXL", $subr_name, "HDR = $HDR\n"); |
| } |
| close (HI); |
| if ($first_call) |
| { |
| gp_message ("debug", $subr_name, "wrote file $outfile"); |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "updated file $outfile"); |
| } |
| #----------------------------------------------- |
| |
| } #-- End of subroutine get_hdr_info |
| |
| #------------------------------------------------------------------------------ |
| # Get the home directory and the location(s) of the configuration file on the |
| # current system. |
| #------------------------------------------------------------------------------ |
| sub get_home_dir_and_rc_path |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($rc_file_name) = @_; |
| |
| my @rc_file_paths; |
| my $target_cmd; |
| my $home_dir; |
| my $error_code; |
| |
| $target_cmd = $g_mapped_cmds{"printenv"} . " HOME"; |
| |
| ($error_code, $home_dir) = execute_system_cmd ($target_cmd); |
| |
| if ($error_code != 0) |
| { |
| my $msg = "cannot find a setting for HOME - please set this"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| else |
| |
| #------------------------------------------------------------------------------ |
| # The home directory is known and we can define the locations for the |
| # configuration file. |
| #------------------------------------------------------------------------------ |
| { |
| @rc_file_paths = (".", "$home_dir"); |
| } |
| |
| gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths"); |
| |
| return ($home_dir, \@rc_file_paths); |
| |
| } #-- End of subroutine get_home_dir_and_rc_path |
| |
| #------------------------------------------------------------------------------ |
| # This subroutine generates a list with the hot functions. |
| #------------------------------------------------------------------------------ |
| sub get_hot_functions |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_; |
| |
| my @exp_dir_list = @{ $exp_dir_list_ref }; |
| |
| my $cmd_output; |
| my $error_code; |
| my $expr_name; |
| my $first_metric; |
| my $gp_display_text_cmd; |
| my $ignore_value; |
| |
| my @sort_fields = (); |
| |
| $expr_name = join (" ", @exp_dir_list); |
| |
| gp_message ("debug", $subr_name, "expr_name = $expr_name"); |
| |
| my $outputdir = append_forward_slash ($input_string); |
| |
| my $script_file = $outputdir."gp-fsummary.script"; |
| my $outfile = $outputdir."gp-fsummary.out"; |
| my $result_file = $outputdir."gp-fsummary.stderr"; |
| my $gp_error_file = $outputdir.$g_gp_error_logfile; |
| |
| @sort_fields = split (":", $summary_metrics); |
| |
| #------------------------------------------------------------------------------ |
| # This is extremely unlikely to happen, but if so, it is a fatal error. |
| #------------------------------------------------------------------------------ |
| my $number_of_elements = scalar (@sort_fields); |
| |
| gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements"); |
| |
| if ($number_of_elements == 0) |
| { |
| my $msg = "there are $number_of_elements in the metrics list"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Get the summary of the hot functions |
| #------------------------------------------------------------------------------ |
| open (SCRIPT, ">", $script_file) |
| or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); |
| gp_message ("debug", $subr_name, "opened script file $script_file for writing"); |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Check what this is about: |
| # Attributed User CPU Time=a.user : for calltree - see P37 in manual |
| #------------------------------------------------------------------------------ |
| print SCRIPT "# limit 0\n"; |
| print SCRIPT "limit 0\n"; |
| print SCRIPT "# metrics $summary_metrics\n"; |
| print SCRIPT "metrics $summary_metrics\n"; |
| print SCRIPT "# thread_select all\n"; |
| print SCRIPT "thread_select all\n"; |
| |
| #------------------------------------------------------------------------------ |
| # Use first out of summary metrics as first (it doesn't matter which one) |
| # $first_metric = (split /:/,$summary_metrics)[0]; |
| #------------------------------------------------------------------------------ |
| |
| $first_metric = $sort_fields[0]; |
| |
| print SCRIPT "# outfile $outfile\n"; |
| print SCRIPT "outfile $outfile\n"; |
| print SCRIPT "# sort $first_metric\n"; |
| print SCRIPT "sort $first_metric\n"; |
| print SCRIPT "# fsummary\n"; |
| print SCRIPT "fsummary\n"; |
| |
| close SCRIPT; |
| |
| my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name"; |
| |
| gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions"); |
| |
| $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; |
| |
| ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); |
| |
| if ($error_code != 0) |
| { |
| $ignore_value = msg_display_text_failure ($gp_display_text_cmd, |
| $error_code, |
| $gp_error_file); |
| gp_message ("abort", $subr_name, "execution terminated"); |
| my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd"; |
| gp_message ("abort", $subr_name, $msg); |
| } |
| |
| return ($outfile,\@sort_fields); |
| |
| } #-- End of subroutine get_hot_functions |
| |
| #------------------------------------------------------------------------------ |
| # For a given function name, return the index into "function_info". This |
| # index gives access to all the meta data for the input function. |
| #------------------------------------------------------------------------------ |
| sub get_index_function_info |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($routine_ref, $hex_address_ref, $function_info_ref) = @_; |
| |
| my $routine = ${ $routine_ref }; |
| my $hex_address = ${ $hex_address_ref }; |
| my @function_info = @{ $function_info_ref }; |
| |
| #------------------------------------------------------------------------------ |
| # Check if this function has multiple occurrences. |
| #------------------------------------------------------------------------------ |
| gp_message ("debug", $subr_name, "check for multiple occurrences"); |
| |
| my $current_address = $hex_address; |
| my $alt_name = $routine; |
| |
| my $found_a_match; |
| my $index_into_function_info; |
| my $target_tag; |
| |
| if (not exists ($g_multi_count_function{$routine})) |
| { |
| #------------------------------------------------------------------------------ |
| # There is only a single occurrence and it is straightforward to get the tag. |
| #-------------------------------------------------------------------------- |
| ## push (@final_function_names, $routine); |
| if (exists ($g_map_function_to_index{$routine})) |
| { |
| $index_into_function_info = $g_map_function_to_index{$routine}[0]; |
| } |
| else |
| { |
| my $msg = "no entry for $routine in g_map_function_to_index"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| } |
| else |
| { |
| #------------------------------------------------------------------------------ |
| # The function name has more than one occurrence and we need to find the one |
| # that matches with the address. |
| #------------------------------------------------------------------------------ |
| $found_a_match = $FALSE; |
| gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); |
| for my $ref (keys @{ $g_map_function_to_index{$routine} }) |
| { |
| my $ref_index = $g_map_function_to_index{$routine}[$ref]; |
| my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; |
| |
| gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); |
| gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Do this substitution when storing "addressobjtext" in function_info. |
| #------------------------------------------------------------------------------ |
| $addr_offset =~ s/^@\d+://; |
| gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); |
| if ($addr_offset eq $current_address) |
| { |
| $found_a_match = $TRUE; |
| $index_into_function_info = $ref_index; |
| last; |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # If there is no match, something has gone really wrong and we bail out. |
| #------------------------------------------------------------------------------ |
| if (not $found_a_match) |
| { |
| my $msg = "cannot find the mapping in function_info for function $routine"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| } |
| |
| return (\$index_into_function_info); |
| |
| } #-- End of subroutine get_index_function_info |
| |
| #------------------------------------------------------------------------------ |
| # Get the setting for LANG, or assign a default if it is not set. |
| #------------------------------------------------------------------------------ |
| sub get_LANG_setting |
| { |
| my $subr_name = get_my_name (); |
| |
| my $error_code; |
| my $lang_setting; |
| my $target_cmd; |
| my $command_string; |
| my $LANG; |
| |
| $target_cmd = $g_mapped_cmds{"printenv"}; |
| #------------------------------------------------------------------------------ |
| # Use the printenv command to get the settings for LANG. |
| #------------------------------------------------------------------------------ |
| if ($target_cmd eq "road to nowhere") |
| { |
| $error_code = 1; |
| } |
| else |
| { |
| $command_string = $target_cmd . " LANG"; |
| ($error_code, $lang_setting) = execute_system_cmd ($command_string); |
| } |
| |
| if ($error_code == 0) |
| { |
| chomp ($lang_setting); |
| $LANG = $lang_setting; |
| } |
| else |
| { |
| $LANG = $g_default_setting_lang; |
| my $msg = "cannot find a setting for LANG - use a default setting"; |
| gp_message ("warning", $subr_name, $msg); |
| } |
| |
| return ($LANG); |
| |
| } #-- End of subroutine get_LANG_setting |
| |
| #------------------------------------------------------------------------------ |
| # This subroutine gathers the basic information about the metrics. |
| #------------------------------------------------------------------------------ |
| sub get_metrics_data |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_; |
| |
| my @exp_dir_list = @{ $exp_dir_list_ref }; |
| |
| my $cmd_options; |
| my $cmd_output; |
| my $error_code; |
| my $expr_name; |
| my $metrics_cmd; |
| my $metrics_output; |
| my $target_cmd; |
| |
| $expr_name = join (" ", @exp_dir_list); |
| |
| gp_message ("debug", $subr_name, "expr_name = $expr_name"); |
| |
| #------------------------------------------------------------------------------ |
| # Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is |
| # to get all the output in files $outfile1 and $outfile2. These are then |
| # parsed. |
| #------------------------------------------------------------------------------ |
| $cmd_options = " -viewmode machine -compare off -thread_select all"; |
| $cmd_options .= " -outfile $outfile2"; |
| $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name"; |
| |
| $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file"; |
| |
| gp_message ("debug", $subr_name, "command used to gather the information:"); |
| gp_message ("debug", $subr_name, $metrics_cmd); |
| |
| ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd); |
| |
| #------------------------------------------------------------------------------ |
| # Error handling. Any error that occurred is fatal and execution |
| # should be aborted by the caller. |
| #------------------------------------------------------------------------------ |
| if ($error_code == 0) |
| { |
| gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2"); |
| } |
| else |
| { |
| $target_cmd = $g_mapped_cmds{"cat"} . " $error_file"; |
| |
| ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); |
| |
| chomp ($cmd_output); |
| |
| gp_message ("error", $subr_name, "contents of file $error_file:"); |
| gp_message ("error", $subr_name, $cmd_output); |
| } |
| |
| return ($error_code); |
| |
| } #-- End of subroutine get_metrics_data |
| |
| #------------------------------------------------------------------------------ |
| # Wrapper that returns the last part of the subroutine name. The assumption is |
| # that the last part of the input name is of the form "aa::bb" or just "bb". |
| #------------------------------------------------------------------------------ |
| sub get_my_name |
| { |
| my $called_by = (caller (1))[3]; |
| my @parts = split ("::", $called_by); |
| return ($parts[$#parts]); |
| |
| ## my ($the_full_name_ref) = @_; |
| |
| ## my $the_full_name = ${ $the_full_name_ref }; |
| ## my $last_part; |
| |
| #------------------------------------------------------------------------------ |
| # If the regex below fails, use the full name." |
| #------------------------------------------------------------------------------ |
| ## $last_part = $the_full_name; |
| |
| #------------------------------------------------------------------------------ |
| # Capture the last part if there are multiple parts separated by "::". |
| #------------------------------------------------------------------------------ |
| ## if ($the_full_name =~ /.*::(.+)$/) |
| ## { |
| ## if (defined ($1)) |
| ## { |
| ## $last_part = $1; |
| ## } |
| ## } |
| |
| ## return (\$last_part); |
| |
| } #-- End of subroutine get_my_name |
| |
| #------------------------------------------------------------------------------ |
| # Determine the characteristics of the current system |
| #------------------------------------------------------------------------------ |
| sub get_system_config_info |
| { |
| #------------------------------------------------------------------------------ |
| # The output from the "uname" command is used for this. Although not all of |
| # these are currently used, we store all fields in separate variables. |
| #------------------------------------------------------------------------------ |
| # |
| #------------------------------------------------------------------------------ |
| # The options supported on uname from GNU coreutils 8.22: |
| #------------------------------------------------------------------------------ |
| # -a, --all print all information, in the following order, |
| # except omit -p and -i if unknown: |
| # -s, --kernel-name print the kernel name |
| # -n, --nodename print the network node hostname |
| # -r, --kernel-release print the kernel release |
| # -v, --kernel-version print the kernel version |
| # -m, --machine print the machine hardware name |
| # -p, --processor print the processor type or "unknown" |
| # -i, --hardware-platform print the hardware platform or "unknown" |
| # -o, --operating-system print the operating system |
| #------------------------------------------------------------------------------ |
| # Sample output: |
| # Linux ruudvan-vm-2-8-20200701 4.14.35-2025.400.8.el7uek.x86_64 #2 SMP Wed Aug 26 12:22:05 PDT 2020 x86_64 x86_64 x86_64 GNU/Linux |
| #------------------------------------------------------------------------------ |
| my $subr_name = get_my_name (); |
| |
| my $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 .= "/"; |
| |
| gp_message ("debug", $subr_name, "enter subroutine"); |
| |
| my %metric_description = %{ $metric_description_ref }; |
| |
| for my $m (keys %metric_description) |
| { |
| gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}"); |
| } |
| |
| $re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC"); |
| ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex"); |
| if ($error_code != 0 ) |
| { |
| gp_message ("abort", $subr_name, "execution terminated"); |
| } |
| |
| for my $field (@sort_fields) |
| { |
| $re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC"); |
| ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex"); |
| if ($error_code != 0 ) |
| { |
| gp_message ("abort", $subr_name, "execution terminated"); |
| } |
| } |
| |
| $re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC"); |
| ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex"); |
| if ($error_code != 0 ) |
| { |
| gp_message ("abort", $subr_name, "execution terminated"); |
| } |
| |
| if ($g_user_settings{"calltree"}{"current_value"} eq "on") |
| { |
| $re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC"); |
| ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex"); |
| if ($error_code != 0 ) |
| { |
| gp_message ("abort", $subr_name, "execution terminated"); |
| } |
| } |
| |
| return (0); |
| |
| } #-- End of subroutine preprocess_function_files |
| |
| #------------------------------------------------------------------------------ |
| # Print the 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 $replace_quote_regex = '"/\"'; |
| my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])'; |
| |
| my %addressobj_index = (); |
| my %function_address_info = (); |
| my $function_address_info_ref; |
| |
| $outputdir = append_forward_slash ($outputdir); |
| |
| my %functions_per_metric_indexes = (); |
| my $functions_per_metric_indexes_ref; |
| |
| my %functions_per_metric_first_index = (); |
| my $functions_per_metric_first_index_ref; |
| |
| my %routine_list = (); |
| my %handled_routines = (); |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Name cleanup needed. |
| #------------------------------------------------------------------------------ |
| |
| my $number_of_metrics; |
| my $expr_name; |
| my $routine; |
| my $tmp; |
| my $loadobj; |
| my $PCA; |
| my $address_field; |
| my $limit_txt; |
| my $n_metrics_text; |
| my $disfile; |
| my $srcfile; |
| my $RIN; |
| my $gp_listings_cmd; |
| my $gp_display_text_cmd; |
| my $ignore_value; |
| |
| my $result_file = $outputdir . "gp-listings.out"; |
| my $gp_error_file = $outputdir . "gp-listings.err"; |
| |
| my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; |
| my $decimal_separator = $g_locale_settings{"decimal_separator"}; |
| my $length_of_string = length ($outputdir); |
| |
| $expr_name = join (" ", @exp_dir_list); |
| |
| gp_message ("debug", $subr_name, "expr_name = $expr_name"); |
| |
| #------------------------------------------------------------------------------ |
| # Loop over the files in $outputdir. |
| #------------------------------------------------------------------------------ |
| while (glob ($outputdir.'*.sort.func-PC')) |
| { |
| my $metric; |
| my $infile; |
| my $ignore_value; |
| my $suffix_not_used; |
| |
| $infile = $_; |
| |
| ($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC"); |
| |
| gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); |
| gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-"); |
| |
| # Function_info creates the functions files from the PC ones |
| # as well as culling PC and metric information |
| |
| ($function_address_info_ref, |
| $functions_per_metric_first_index_ref, |
| $functions_per_metric_indexes_ref) = function_info ( |
| $outputdir, |
| $infile, |
| $metric, |
| $LINUX_vDSO_ref); |
| |
| @{$function_address_info{$metric}} = @{$function_address_info_ref}; |
| %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref}; |
| %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref}; |
| |
| $ignore_value = print_metric_function_array ($metric, |
| "function_address_info", |
| \@{$function_address_info{$metric}}); |
| $ignore_value = print_metric_function_hash ("hash_hash", $metric, |
| "functions_per_metric_first_index", |
| \%{$functions_per_metric_first_index{$metric}}); |
| $ignore_value = print_metric_function_hash ("hash_array", $metric, |
| "functions_per_metric_indexes", |
| \%{$functions_per_metric_indexes{$metric}}); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Get header info for use in post processing er_html output |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "get_hdr_info section"); |
| |
| get_hdr_info ($outputdir, $outputdir."functions.sort.func"); |
| |
| for my $field (@sort_fields) |
| { |
| get_hdr_info ($outputdir, $outputdir."$field.sort.func"); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Caller-callee |
| #------------------------------------------------------------------------------ |
| get_hdr_info ($outputdir, $outputdir."calls.sort.func"); |
| |
| #------------------------------------------------------------------------------ |
| # Calltree |
| #------------------------------------------------------------------------------ |
| if ($g_user_settings{"calltree"}{"current_value"} eq "on") |
| { |
| get_hdr_info ($outputdir, $outputdir."calltree.sort.func"); |
| } |
| |
| gp_message ("debug", $subr_name, "process functions"); |
| |
| my $scriptfile = $outputdir.'gp-script'; |
| my $script_metrics = "$summary_metrics"; |
| my $func_limit = $g_user_settings{"func_limit"}{"current_value"}; |
| |
| open (SCRIPT, ">", $scriptfile) |
| or die ("Unable to create script file $scriptfile - '$!'"); |
| gp_message ("debug", $subr_name, "opened script file $scriptfile for writing"); |
| |
| print SCRIPT "# limit $func_limit\n"; |
| print SCRIPT "limit $func_limit\n"; |
| print SCRIPT "# thread_select all\n"; |
| print SCRIPT "thread_select all\n"; |
| print SCRIPT "# metrics $script_metrics\n"; |
| print SCRIPT "metrics $script_metrics\n"; |
| |
| for my $metric (@sort_fields) |
| { |
| gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}"); |
| |
| $total_attributed_time = 0; |
| $current_attributed_time = 0; |
| |
| $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total> |
| if ($convert_to_dot) |
| { |
| $value =~ s/$decimal_separator/\./; |
| } |
| $total_attributed_time = $value; |
| |
| #------------------------------------------------------------------------------ |
| # start at 1 - skipping <Total> |
| #------------------------------------------------------------------------------ |
| for my $INDEX (1 .. $#{$function_address_info{$metric}}) |
| { |
| #------------------------------------------------------------------------------ |
| #Looking to handle at least 99% of the time - or what the user asked for |
| #------------------------------------------------------------------------------ |
| $value = $function_address_info{$metric}[$INDEX]{"metric_value"}; |
| $routine = $function_address_info{$metric}[$INDEX]{"routine"}; |
| |
| gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time"); |
| gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)"); |
| |
| if ($convert_to_dot) |
| { |
| $value =~ s/$decimal_separator/\./; |
| } |
| |
| if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or |
| ( ($total_attributed_time == 0) and ($value>0) ) or |
| $process_all_functions) |
| { |
| $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"}; |
| |
| if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA})) |
| { |
| gp_message ("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}"); |
| } |
| if (not exists ($function_address_and_index{$routine}{$PCA})) |
| { |
| gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}"); |
| } |
| |
| if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and |
| exists ($function_address_and_index{$routine}{$PCA})) |
| { |
| #------------------------------------------------------------------------------ |
| # handled_routines now contains $RI from "first_metric" (?) |
| #------------------------------------------------------------------------------ |
| $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; |
| my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; |
| if ($metric_description{$metric} =~ /Exclusive Total CPU Time/) |
| { |
| $routine_list{$routine} = 1 |
| } |
| |
| gp_message ("debugXL", $subr_name, " $routine is candidate"); |
| } |
| else |
| { |
| die ("internal error for metric $metric and routine $routine"); |
| } |
| |
| $current_attributed_time += $value; |
| } |
| } |
| } |
| #------------------------------------------------------------------------------ |
| # Sort numerically in ascending order. |
| #------------------------------------------------------------------------------ |
| for my $routine_index (sort {$a <=> $b} keys %handled_routines) |
| { |
| $routine = $function_info[$routine_index]{"routine"}; |
| gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine"); |
| next unless $routine_list{$routine}; |
| |
| # not used $source = $function_info[$routine_index]{"Source File"}; |
| |
| $function_info[$routine_index]{"srcline"} = ""; |
| $address_field = $function_info[$routine_index]{"addressobjtext"}; |
| |
| ## $disfile = "file\.$routine_index\.dis"; |
| $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"}; |
| $srcfile = ""; |
| $srcfile = "file\.$routine_index\.src.txt"; |
| |
| #------------------------------------------------------------------------------ |
| # If the file is unknown, we can disassemble anyway and add disassembly |
| # to the script. |
| #------------------------------------------------------------------------------ |
| print SCRIPT "# outfile $outputdir"."$disfile\n"; |
| print SCRIPT "outfile $outputdir"."$disfile\n"; |
| #------------------------------------------------------------------------------ |
| # TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope. |
| #------------------------------------------------------------------------------ |
| $tmp = $routine; |
| $tmp =~ s/$replace_quote_regex//g; |
| print SCRIPT "# disasm \"$tmp\" $address_field\n"; |
| print SCRIPT "disasm \"$tmp\" $address_field\n"; |
| if ($srcfile=~/file/) |
| { |
| print SCRIPT "# outfile $outputdir"."$srcfile\n"; |
| print SCRIPT "outfile $outputdir"."$srcfile\n"; |
| print SCRIPT "# source \"$tmp\" $address_field\n"; |
| print SCRIPT "source \"$tmp\" $address_field\n"; |
| } |
| |
| if ($routine =~ /$find_clone_regex/) |
| { |
| my ($clone_routine) = $1.$2.$3.$4; |
| my ($clone) = $3; |
| } |
| } |
| close SCRIPT; |
| |
| #------------------------------------------------------------------------------ |
| # Remember the number of handled routines depends on the limit setting passed |
| # to er_print together with the sorting order on the metrics, which usually results |
| # in different routines at the top. Thus $RIN below can be greater than the limit. |
| #------------------------------------------------------------------------------ |
| |
| $RIN = scalar (keys %handled_routines); |
| |
| if (!$func_limit) |
| { |
| $limit_txt = "unlimited"; |
| } |
| else |
| { |
| $limit_txt = $func_limit - 1; |
| } |
| |
| $number_of_metrics = scalar (@sort_fields); |
| |
| $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics"; |
| |
| gp_message ("debugXL", $subr_name, "built function list with $RIN functions"); |
| gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt"); |
| |
| # add ELF program header offset |
| |
| for my $routine_index (sort {$a <=> $b} keys %handled_routines) |
| { |
| $routine = $function_info[$routine_index]{"routine"}; |
| $loadobj = $function_info[$routine_index]{"Load Object"}; |
| |
| gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch"); |
| |
| if ($loadobj ne '') |
| { |
| # <Truncated-stack> is associated with <Total>. Its load object is <Total> |
| if ($loadobj eq "<Total>") |
| { |
| next; |
| } |
| # Have seen a routine called <Unknown>. Its load object is <Unknown> |
| if ($loadobj eq "<Unknown>") |
| { |
| next; |
| } |
| ############################################################################### |
| ## RUUD: The new approach gives a different result. Investigate this. |
| # |
| # Turns out the new code improves the result. The addresses are now correct |
| # and as a result, more ftag's are created later on. |
| ############################################################################### |
| gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); |
| |
| $function_info[$routine_index]{"addressobj"} += bigint::hex ( |
| determine_base_va_address ( |
| $executable_name, |
| $base_va_executable, |
| $loadobj, |
| $routine)); |
| $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index; |
| |
| gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); |
| gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}"); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Get the disassembly and source code output. |
| #------------------------------------------------------------------------------ |
| $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " . |
| "-compare off -script $scriptfile $expr_name"; |
| |
| $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file"; |
| |
| gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd"); |
| |
| gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output"); |
| |
| my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); |
| |
| if ($error_code != 0) |
| { |
| $ignore_value = msg_display_text_failure ($gp_display_text_cmd, |
| $error_code, |
| $gp_error_file); |
| gp_message ("abort", $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 $name_regex; |
| my $no_of_fields; |
| my $metrics_length; |
| my $missing_digits; |
| my $remaining_part_header; |
| my $routine; |
| my $routine_length; |
| my $scan_header = $FALSE; |
| my $scan_function_data = $FALSE; |
| my $string_length; |
| my $total_header_lines; |
| |
| my @address_field = (); |
| my @fields = (); |
| my @function_data = (); |
| my @function_names = (); |
| my @function_view_array = (); |
| my @function_view_modified = (); |
| my @header_lines = (); |
| my @metrics_part = (); |
| my @metric_values = (); |
| |
| #------------------------------------------------------------------------------ |
| # The regex section. |
| #------------------------------------------------------------------------------ |
| my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; |
| my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)'; |
| my $empty_line_regex = '^\s*$'; |
| my $catch_all_regex = '\s*(.*)'; |
| my $get_hex_address_regex = '(\d+):0x(\S+)'; |
| my $get_addr_offset_regex = '^@\d+:'; |
| my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)'; |
| my $backward_slash_regex = '\/'; |
| |
| #------------------------------------------------------------------------------ |
| if (is_file_empty ($overview_file)) |
| { |
| gp_message ("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"); |
| |
| #------------------------------------------------------------------------------ |
| # Parse the function view info and store the data. |
| #------------------------------------------------------------------------------ |
| my $max_header_length = 0; |
| my $max_metrics_length = 0; |
| |
| #------------------------------------------------------------------------------ |
| # Loop over all the lines. Extract the header, metric values, function names, |
| # and the addresses. |
| # |
| # This is also where the maximum lengths for the header and metric lines are |
| # computed. This is used to get the correct alignment in the HTML output. |
| #------------------------------------------------------------------------------ |
| for (my $line = 0; $line <= $#function_data; $line++) |
| { |
| $input_line = $function_data[$line]; |
| gp_message ("debugXL", $subr_name, "input_line = $input_line"); |
| |
| #------------------------------------------------------------------------------ |
| # The table header is assumed to start at the line that has "Name" in it. |
| # The header ends when we see the function name "<Total>". |
| #------------------------------------------------------------------------------ |
| if ($input_line =~ /$header_name_regex/) |
| { |
| $scan_header = $TRUE; |
| } |
| elsif ($input_line =~ /$total_marker_regex/) |
| { |
| $scan_header = $FALSE; |
| $scan_function_data = $TRUE; |
| } |
| |
| if ($scan_header) |
| { |
| #------------------------------------------------------------------------------ |
| # This group is only defined for the first line of the header and $4 contains |
| # the remaining part of the line after "Name", without the leading spaces. |
| #------------------------------------------------------------------------------ |
| if (defined ($4)) |
| { |
| $remaining_part_header = $4; |
| my $msg = "remaining_part_header = $remaining_part_header"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Determine the maximum length of the header. This needs to be done before |
| # the HTML controls are added. |
| #------------------------------------------------------------------------------ |
| my $header_length = length ($remaining_part_header); |
| $max_header_length = max ($max_header_length, $header_length); |
| |
| #------------------------------------------------------------------------------ |
| # TBD Should change this and not yet include html in header_lines |
| #------------------------------------------------------------------------------ |
| $html_line = "<b>" . $remaining_part_header . "</b>"; |
| |
| push (@header_lines, $html_line); |
| |
| gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); |
| gp_message ("debugXL", $subr_name, "html_line = $html_line"); |
| } |
| #------------------------------------------------------------------------------ |
| # Captures the subsequent header lines. Assume they exist. |
| #------------------------------------------------------------------------------ |
| elsif ($input_line =~ /$catch_all_regex/) |
| { |
| $header_line = $1; |
| gp_message ("debugXL", $subr_name, "header_line = $header_line"); |
| |
| my $header_length = length ($header_line); |
| $max_header_length = max ($max_header_length, $header_length); |
| |
| #------------------------------------------------------------------------------ |
| # TBD Should change this and not yet include html in header_lines |
| #------------------------------------------------------------------------------ |
| $html_line = "<b>" . $header_line . "</b>"; |
| |
| push (@header_lines, $html_line); |
| |
| gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); |
| gp_message ("debugXL", $subr_name, "html_line = $html_line"); |
| } |
| } |
| #------------------------------------------------------------------------------ |
| # This is a line with function data. |
| #------------------------------------------------------------------------------ |
| if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/))) |
| { |
| @fields = split (" ", $input_line); |
| |
| $no_of_fields = $#fields + 1; |
| $elements_in_name = $no_of_fields - $number_of_metrics - 1; |
| |
| gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name"); |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Handle this better in case a function entry has more than 2 words. |
| # Build the regex dynamically and use eval to capture the correct group. |
| # CHECK CODE IN GENERATE_CALLER_CALLEE |
| #------------------------------------------------------------------------------ |
| if ($elements_in_name == 1) |
| { |
| $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)'; |
| } |
| elsif ($elements_in_name == 2) |
| { |
| $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)'; |
| } |
| else |
| { |
| gp_message ("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit"); |
| } |
| |
| if ($input_line =~ /$name_regex/) |
| { |
| $full_hex_address = $1; |
| $routine = $2; |
| |
| if ($elements_in_name == 1) |
| { |
| $all_metrics = $3; |
| } |
| elsif ($elements_in_name == 2) |
| { |
| $all_metrics = $5; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # In case the last metric is 0. only, we append 3 extra characters that |
| # represent zero. We cannot change the number to 0.000 though because that |
| # has a different interpretation than 0. |
| # In a later phase, the "ZZZ" symbol will be removed again, but for now it |
| # creates consistency in, for example, the length of the metrics part. |
| #------------------------------------------------------------------------------ |
| if ($all_metrics =~ /$zero_dot_at_end_regex/) |
| { |
| if (defined ($1) ) |
| { |
| #------------------------------------------------------------------------------ |
| # Somewhat overkill, but remove the leading "\" from the decimal separator |
| # in the debug print since it is used for internal purposes only. |
| #------------------------------------------------------------------------------ |
| my $decimal_point = $decimal_separator; |
| $decimal_point =~ s/$backward_slash_regex//; |
| my $txt = "all_metrics = $all_metrics ended with 0"; |
| $txt .= "$decimal_point ($decimal_separator)"; |
| gp_message ("debugXL", $subr_name, $txt); |
| |
| $all_metrics .= "ZZZ"; |
| } |
| } |
| $metrics_length = length ($all_metrics); |
| $max_metrics_length = max ($max_metrics_length, $metrics_length); |
| gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); |
| |
| if ($full_hex_address =~ /$get_hex_address_regex/) |
| { |
| $hex_address = "0x" . $2; |
| } |
| |
| push (@address_field, $hex_address); |
| push (@metric_values, $all_metrics); |
| |
| #------------------------------------------------------------------------------ |
| # Record the function name "as is". Below we figure out what the final name |
| # should be in case there are multiple occurrences of the same name. |
| # |
| # The reason to decouple this is to avoid the code gets too complex here. |
| #------------------------------------------------------------------------------ |
| push (@function_names, $routine); |
| } |
| } |
| } #-- End of loop over the input lines |
| |
| #------------------------------------------------------------------------------ |
| # Store the maximum lengths for the header and metrics. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length"); |
| gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length"); |
| |
| $function_view_structure{"max header length"} = $max_header_length; |
| $function_view_structure{"max metrics length"} = $max_metrics_length; |
| |
| #------------------------------------------------------------------------------ |
| # Determine the final name for the functions and set up the HTML block. |
| #------------------------------------------------------------------------------ |
| my @final_html_function_block = (); |
| my @function_index_list = (); |
| |
| #------------------------------------------------------------------------------ |
| # First, an index list is built. If we are to index the functions in order of |
| # appearance in the function overview from 0 to n-1, the value of the array |
| # for index "i" is the index into the large "function_info" structure. This |
| # has the final name, the html function block, etc. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| ## TBD: Use get_index_function_info??!! |
| #------------------------------------------------------------------------------ |
| for my $i (keys @function_names) |
| { |
| #------------------------------------------------------------------------------ |
| # Get the function name and the address from the function overview. The |
| # address is used to differentiate in case a function has multiple occurences. |
| #------------------------------------------------------------------------------ |
| my $routine = $function_names[$i]; |
| my $current_address = $address_field[$i]; |
| |
| my $found_a_match = $FALSE; |
| my $final_function_name; |
| my $ref_index; |
| |
| #------------------------------------------------------------------------------ |
| # Check if there are duplicate entries for this function. If there are, use |
| # the address to find the right match in the function_info structure. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences"); |
| if (exists ($g_multi_count_function{$routine})) |
| { |
| gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); |
| for my $ref (keys @{ $g_map_function_to_index{$routine} }) |
| { |
| my $ref_index = $g_map_function_to_index{$routine}[$ref]; |
| my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; |
| #------------------------------------------------------------------------------ |
| # The address has the following format: 6:0x0003af50, but we only need the |
| # part after the colon and remove the first part. |
| #------------------------------------------------------------------------------ |
| $addr_offset =~ s/$get_addr_offset_regex//; |
| |
| gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index"); |
| gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); |
| gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); |
| |
| if ($addr_offset eq $current_address) |
| #------------------------------------------------------------------------------ |
| # There is a match and we can store the index. |
| #------------------------------------------------------------------------------ |
| { |
| $found_a_match = $TRUE; |
| push (@function_index_list, $ref_index); |
| last; |
| } |
| } |
| } |
| else |
| { |
| #------------------------------------------------------------------------------ |
| # This is the easy case. There is only one index value. We do check if the |
| # array element that contains it, exists. If this is not the case, something |
| # has gone horribly wrong earlier and we need to bail out. |
| #------------------------------------------------------------------------------ |
| if (defined ($g_map_function_to_index{$routine}[0])) |
| { |
| $found_a_match = $TRUE; |
| $ref_index = $g_map_function_to_index{$routine}[0]; |
| push (@function_index_list, $ref_index); |
| my $final_function_name = $function_info[$ref_index]{"routine"}; |
| gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name"); |
| } |
| } |
| if (not $found_a_match) |
| #------------------------------------------------------------------------------ |
| # This should not happen. All we can do is print an error message and stop. |
| #------------------------------------------------------------------------------ |
| { |
| my $msg = "cannot find the index for $routine: found_a_match = "; |
| $msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # The loop over all function names has completed and @function_index_list |
| # contains the index values into @function_info for the functions. |
| # |
| # All we now need to do is to retrieve the correct field(s) from the array. |
| #------------------------------------------------------------------------------ |
| for my $i (keys @function_index_list) |
| { |
| my $index_for_function = $function_index_list[$i]; |
| push (@final_html_function_block, $function_info[$index_for_function]{"html function block"}); |
| } |
| for my $i (keys @final_html_function_block) |
| { |
| my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]"; |
| gp_message ("debugXL", $subr_name, $txt); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Since the numbers are right aligned, we know that any difference between the |
| # metric line length and the maximum must be caused by the first column. All |
| # we need to do is to prepend spaces in case of a difference. |
| # |
| # While we have the line with the metric values, we also replace ZZZ by 3 |
| # spaces. |
| #------------------------------------------------------------------------------ |
| for my $i (keys @metric_values) |
| { |
| if (length ($metric_values[$i]) < $max_metrics_length) |
| { |
| my $pad = $max_metrics_length - length ($metric_values[$i]); |
| my $spaces = ""; |
| for my $s (1 .. $pad) |
| { |
| $spaces .= " "; |
| } |
| $metric_values[$i] = $spaces . $metric_values[$i]; |
| } |
| $metric_values[$i] =~ s/ZZZ/ /g; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Determine the column widths. The start and end index of the words in the |
| # input line are stored in elements 0 and 1 of @word_index_values. |
| # |
| # The assumption made is that the first digit of a metric value on the first |
| # line is left # aligned with the header text. These are the Total values |
| # and other than for some derived metrics, e.g. CPI, should be the largest. |
| # |
| # The positions of the start of the value is what we should then use for the |
| # word "(sort)" to start. |
| # |
| # For example: |
| # |
| # Excl. Excl. CPU Excl. Excl. Excl. Excl. |
| # Total Cycles Instructions Last-Level IPC CPI |
| # CPU sec. sec. Executed Cache Misses |
| # 174.664 179.250 175838403203 1166209617 0.428 2.339 |
| #------------------------------------------------------------------------------ |
| |
| my $foundit_ref; |
| my $foundit; |
| my @index_values = (); |
| my $index_values_ref; |
| |
| #------------------------------------------------------------------------------ |
| # Search for "Excl." in the top row. The metric values are aligned with this |
| # word and we can use it to position "(sort)" in the last header line. |
| # |
| # In @index_values, we store the position(s) of "Excl." in the header line. |
| # If none can be found, an exception is raised because at least one should |
| # be there. |
| # |
| # TBD: Check if this can be done only once. |
| #------------------------------------------------------------------------------ |
| my $target_keyword = "Excl."; |
| |
| ($foundit_ref, $index_values_ref) = find_keyword_in_string ( |
| \$remaining_part_header, |
| \$target_keyword); |
| |
| $foundit = ${ $foundit_ref }; |
| @index_values = @{ $index_values_ref }; |
| |
| if ($foundit) |
| { |
| for my $i (keys @index_values) |
| { |
| my $txt = "index_values[$i] = $index_values[$i]"; |
| gp_message ("debugXL", $subr_name, $txt); |
| } |
| } |
| else |
| { |
| my $msg = "keyword $target_keyword not found in $remaining_part_header"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Compute the number of spaces we need to add between the "(sort)" strings. |
| # |
| # For example: |
| # |
| # 01234567890123456789 |
| # |
| # Excl. Excl. |
| # (sort) (sort) |
| # xxxxxxxx |
| # |
| # The number of spaces required is 14 - 6 = 8. |
| # |
| # The number of spaces to be added is stored in @padding_values. These are |
| # the spaces to be added before the occurrence of "(sort)". This is why the |
| # first padding value is 0. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # TBD: This needs to be done only once. |
| #------------------------------------------------------------------------------ |
| my @padding_values = (); |
| my $P_previous = 0; |
| for my $i (keys @index_values) |
| { |
| my $L = $index_values[$i]; |
| my $P = $L + length ("(sort)"); |
| my $pad_spaces = $L - $P_previous; |
| |
| push (@padding_values, $pad_spaces); |
| |
| $P_previous = $P; |
| } |
| |
| for my $i (keys @padding_values) |
| { |
| my $txt = "padding_values[$i] = $padding_values[$i]"; |
| gp_message ("debugXL", $subr_name, $txt); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Build up the sort line. Mark the current metric and make sure the line is |
| # aligned with the header. |
| #------------------------------------------------------------------------------ |
| my $sort_string = "(sort)"; |
| my $length_sort_string = length ($sort_string); |
| my $sort_line = ""; |
| my @active_metrics = split (":", $summary_metrics); |
| for my $i (0 .. $number_of_metrics-1) |
| { |
| my $pad = $padding_values[$i]; |
| my $metric_value = $active_metrics[$i]; |
| |
| my $spaces = ""; |
| for my $s (1 .. $pad) |
| { |
| $spaces .= " "; |
| } |
| |
| gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad"); |
| |
| if ($metric_value eq $exp_type) |
| #------------------------------------------------------------------------------ |
| # The current metric should have a different background color. |
| #------------------------------------------------------------------------------ |
| { |
| $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . |
| "." . $metric_value . ".html' style='background-color:" . |
| $g_html_color_scheme{"background_selected_sort"} . |
| "\'><b>(sort)</b></a>"; |
| } |
| elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric)) |
| #------------------------------------------------------------------------------ |
| # Set the background color for the sort metric in the main function overview. |
| #------------------------------------------------------------------------------ |
| { |
| $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . |
| "." . $metric_value . ".html' style='background-color:" . |
| $g_html_color_scheme{"background_selected_sort"} . |
| "'><b>(sort)</b></a>"; |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # Do not set a specific background for all other metrics. |
| #------------------------------------------------------------------------------ |
| { |
| $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . |
| "." . $metric_value . ".html'>(sort)</a>"; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Prepend the spaces to ensure correct alignment with the rest of the header. |
| #------------------------------------------------------------------------------ |
| $sort_line .= $spaces . $sort_string; |
| } |
| |
| push (@header_lines, $sort_line); |
| |
| #------------------------------------------------------------------------------ |
| # Print the final results for the header and metrics. |
| #------------------------------------------------------------------------------ |
| for my $i (keys @header_lines) |
| { |
| gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); |
| } |
| for my $i (keys @metric_values) |
| { |
| gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]"); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Construct the lines for the function overview. |
| # |
| # TBD: We could eliminate two structures here because metric_values and |
| # final_html_function_block are only copied and the result stored. |
| #------------------------------------------------------------------------------ |
| for my $i (keys @function_names) |
| { |
| push (@metrics_part, $metric_values[$i]); |
| push (@function_view_array, $final_html_function_block[$i]); |
| } |
| |
| for my $i (0 .. $#function_view_array) |
| { |
| my $msg = "function_view_array[$i] = $function_view_array[$i]"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| #------------------------------------------------------------------------------ |
| # Element "function table" contains the array with all the function view data. |
| #------------------------------------------------------------------------------ |
| $function_view_structure{"header"} = [@header_lines]; |
| $function_view_structure{"metrics part"} = [@metrics_part]; |
| $function_view_structure{"function table"} = [@function_view_array]; |
| |
| return (\%function_view_structure); |
| |
| } #-- End of subroutine process_function_overview |
| |
| #------------------------------------------------------------------------------ |
| # TBD |
| #------------------------------------------------------------------------------ |
| sub process_metrics |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_; |
| |
| my @sort_fields = @{ $sort_fields_ref }; |
| my %metric_description = %{ $metric_description_ref }; |
| my %ignored_metrics = %{ $ignored_metrics_ref }; |
| |
| my $outputdir = append_forward_slash ($input_string); |
| my $LANG = $g_locale_settings{"LANG"}; |
| my $max_len = 0; |
| my $metric_comment; |
| |
| my ($imetricn,$outfile); |
| my ($html_metrics_record,$imetric,$metric); |
| |
| $html_metrics_record = |
| "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . |
| "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . |
| "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n"; |
| |
| $outfile = $outputdir . "metrics.html"; |
| |
| open (METRICSOUT, ">", $outfile) |
| or die ("$subr_name - unable to open file $outfile for writing - '$!'"); |
| gp_message ("debug", $subr_name, "opened file $outfile for writing"); |
| |
| for $metric (@sort_fields) |
| { |
| $max_len = max ($max_len, length ($metric)); |
| gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len"); |
| } |
| |
| # TBD: Check this |
| # for $imetric (@IMETRICS) |
| for $imetric (keys %ignored_metrics) |
| { |
| $max_len = max ($max_len, length ($imetric)); |
| gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len"); |
| } |
| |
| $max_len++; |
| |
| gp_message ("debug", $subr_name, "max_len = $max_len"); |
| |
| $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">"; |
| for $metric (@sort_fields) |
| { |
| my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; |
| gp_message ("debug", $subr_name, "handling metric metric = $metric->$description"); |
| $html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n"; |
| } |
| |
| # $imetricn = scalar (keys %IMETRICS); |
| $imetricn = scalar (keys %ignored_metrics); |
| if ($imetricn) |
| { |
| $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">"; |
| # for $imetric (sort keys %IMETRICS){ |
| for $imetric (sort keys %ignored_metrics) |
| { |
| $metric_comment = "(inclusive, exclusive, and percentages)"; |
| $html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n"; |
| gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment"); |
| } |
| } |
| |
| print METRICSOUT $html_metrics_record; |
| print METRICSOUT $g_html_credits_line; |
| close (METRICSOUT); |
| |
| gp_message ("debug", $subr_name, "closed metrics file $outfile"); |
| |
| return (0); |
| |
| } #-- End of subroutine process_metrics |
| |
| #------------------------------------------------------------------------------ |
| # TBD |
| #------------------------------------------------------------------------------ |
| sub process_metrics_data |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($outfile1, $outfile2, $ignored_metrics_ref) = @_; |
| |
| my %ignored_metrics = %{ $ignored_metrics_ref }; |
| |
| my %metric_value = (); |
| my %metric_description = (); |
| my %metric_found = (); |
| |
| my $user_metrics; |
| my $system_metrics; |
| my $wall_metrics; |
| my $metric_spec; |
| my $metric_flavor; |
| my $metric_visibility; |
| my $metric_name; |
| my $metric_text; |
| my $metricdata; |
| my $metric_line; |
| |
| my $summary_metrics; |
| my $detail_metrics; |
| my $detail_metrics_system; |
| my $call_metrics; |
| |
| if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") |
| { |
| gp_message ("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"}); |
| # get metrics |
| |
| $summary_metrics=''; |
| $detail_metrics=''; |
| $detail_metrics_system=''; |
| $call_metrics = ''; |
| $user_metrics=0; |
| $system_metrics=0; |
| $wall_metrics=0; |
| |
| my ($last_metric,$metric,$value,$i,$r); |
| |
| open (METRICTOTALS, "<", $outfile2) |
| or die ("Unable to open metric value data file $outfile2 for reading - '$!'"); |
| gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data"); |
| |
| #------------------------------------------------------------------------------ |
| # Below an example of the file that has just been opened. The lines I marked |
| # with a * has been wrapped by my for readability. This is not the case in the |
| # file, but makes for a really long line. |
| # |
| # Also, the data comes from one PC experiment and two HWC experiments. |
| #------------------------------------------------------------------------------ |
| # <Total> |
| # Exclusive Total CPU Time: 32.473 (100.0%) |
| # Inclusive Total CPU Time: 32.473 (100.0%) |
| # Exclusive CPU Cycles: 23.586 (100.0%) |
| # " count: 47054706905 |
| # Inclusive CPU Cycles: 23.586 (100.0%) |
| # " count: 47054706905 |
| # Exclusive Instructions Executed: 54417033412 (100.0%) |
| # Inclusive Instructions Executed: 54417033412 (100.0%) |
| # Exclusive Last-Level Cache Misses: 252730685 (100.0%) |
| # Inclusive Last-Level Cache Misses: 252730685 (100.0%) |
| # * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: |
| # * Exclusive Cycles Per Instruction: |
| # * Inclusive Cycles Per Instruction: |
| # * Size: 0 |
| # PC Address: 1:0x00000000 |
| # Source File: (unknown) |
| # Object File: (unknown) |
| # Load Object: <Total> |
| # Mangled Name: |
| # Aliases: |
| #------------------------------------------------------------------------------ |
| |
| while (<METRICTOTALS>) |
| { |
| $metricdata = $_; chomp ($metricdata); |
| gp_message ("debug", $subr_name, "file metrictotals: $metricdata"); |
| |
| #------------------------------------------------------------------------------ |
| # Ignoring whitespace, search for any line with a ":" in it, followed by |
| # a number with or without a dot. So, an integer or floating-point number. |
| #------------------------------------------------------------------------------ |
| if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/) |
| { |
| gp_message ("debug", $subr_name, " candidate => $metricdata"); |
| $metric = $1; |
| $value = $2; |
| if ( ($metric eq "PC Address") or ($metric eq "Size")) |
| { |
| gp_message ("debug", $subr_name, " skipped => $metric $value"); |
| next; |
| } |
| gp_message ("debug", $subr_name, " proceed => $metric $value"); |
| if ($metric eq '" count') |
| #------------------------------------------------------------------------------ |
| # Hardware counter experiments have this info. Note that this line is not the |
| # first one to be encountered, so $last_metric has been defined already. |
| #------------------------------------------------------------------------------ |
| { |
| $metric = $last_metric." Count"; # we presume ....... |
| gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric"); |
| } |
| $i=index ($metricdata,":"); |
| $r=rindex ($metricdata,":"); |
| gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r"); |
| if ($i == $r) |
| { |
| if ($value > 0) # Not interested in metrics contributing zero |
| { |
| $metric_value{$metric} = $value; |
| gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}"); |
| # e.g. $metric_value{Exclusive Total Thread Time} = 302.562 |
| # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484 |
| } |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # TBD This code deals with an old bug and may be removed. |
| #------------------------------------------------------------------------------ |
| { # er_print bug - e.g. |
| # Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%) |
| gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-"); |
| $r=rindex ($metricdata,":",$r-1); |
| if ($r == -1) |
| { # ignore |
| gp_message ("debug", $subr_name, "metrictotals odd line ignored<-"); |
| $last_metric = "foo"; |
| next; |
| } |
| my ($good_part)=substr ($metricdata,$r+1); |
| if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/) |
| { |
| $metric = $1; |
| $value = $2; |
| if ($value>0) # Not interested in metrics contributing zero |
| { |
| $metric_value{$metric} = $value; |
| my $msg = "metrictotals odd line rescued '$metric'=$value"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| } |
| #------------------------------------------------------------------------------ |
| # Preserve the current metric. |
| #------------------------------------------------------------------------------ |
| $last_metric = $metric; |
| } |
| } |
| close (METRICTOTALS); |
| } |
| |
| if (scalar (keys %metric_value) == 0) |
| #------------------------------------------------------------------------------ |
| # If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we |
| # blow up later. |
| # |
| # TBD: See if this can be handled differently. |
| #------------------------------------------------------------------------------ |
| { |
| $metric_value{"Exclusive Total CPU Time"} = 0; |
| gp_message ("debug", $subr_name, "no metrics found and a stub was added"); |
| } |
| |
| for my $metric (sort keys %metric_value) |
| { |
| gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}"); |
| } |
| |
| gp_message ("debug", $subr_name, "proceed to process file $outfile1"); |
| |
| #------------------------------------------------------------------------------ |
| # Open and process the metrics file. |
| #------------------------------------------------------------------------------ |
| open (METRICS, "<", $outfile1) |
| or die ("Unable to open metrics file $outfile1: '$!'"); |
| gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); |
| |
| #------------------------------------------------------------------------------ |
| # Parse the file. This is a typical example: |
| # |
| # Exp Sel Total |
| # === === ===== |
| # 1 all 2 |
| # 2 all 1 |
| # 3 all 2 |
| # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name |
| # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) |
| # Available metrics: |
| # Exclusive Total CPU Time: e.%totalcpu |
| # Inclusive Total CPU Time: i.%totalcpu |
| # Exclusive CPU Cycles: e.+%cycles |
| # Inclusive CPU Cycles: i.+%cycles |
| # Exclusive Instructions Executed: e+%insts |
| # Inclusive Instructions Executed: i+%insts |
| # Exclusive Last-Level Cache Misses: e+%llm |
| # Inclusive Last-Level Cache Misses: i+%llm |
| # Exclusive Instructions Per Cycle: e+IPC |
| # Inclusive Instructions Per Cycle: i+IPC |
| # Exclusive Cycles Per Instruction: e+CPI |
| # Inclusive Cycles Per Instruction: i+CPI |
| # Size: size |
| # PC Address: address |
| # Name: name |
| #------------------------------------------------------------------------------ |
| while (<METRICS>) |
| { |
| $metric_line = $_; |
| chomp ($metric_line); |
| |
| gp_message ("debug", $subr_name, "processing line $metric_line"); |
| #------------------------------------------------------------------------------ |
| # The original regex has bugs because the line should not be allowed to start |
| # with a ":". So this is wrong: |
| # if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) |
| # |
| # This is better: |
| # if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) |
| # |
| # In general, this regex has some potential issues and has been replaced by |
| # the one shown below. |
| # |
| # We select a line that does not start with "Current" and aside from whitespace |
| # starts with anything (although it should be a string with words only), |
| # followed by whitespace and either an "e" or "i". This is called the "flavor" |
| # and is followed by a visibility marker (.,+,%, or !) and a metric name. |
| #------------------------------------------------------------------------------ |
| # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ |
| |
| ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = |
| extract_metric_specifics ($metric_line); |
| |
| # if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) |
| if ($metric_spec eq "skipped") |
| { |
| gp_message ("debug", $subr_name, "skipped line: $metric_line"); |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "line of interest: $metric_line"); |
| |
| $metric_found{$metric_spec} = 1; |
| |
| if ($g_user_settings{"ignore_metrics"}{"defined"}) |
| { |
| gp_message ("debug", $subr_name, "check for $metric_spec"); |
| if (exists ($ignored_metrics{$metric_name})) |
| { |
| gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name"); |
| next; |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # This metric is not on the ignored list and qualifies, so store it. |
| #------------------------------------------------------------------------------ |
| $metric_description{$metric_spec} = $metric_text; |
| |
| # TBD: add for other visibilities too, like + |
| gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}"); |
| |
| if ($metric_flavor ne "e") |
| { |
| gp_message ("debug", $subr_name, "metric $metric_spec is ignored"); |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # Only the exclusive metrics are shown. |
| #------------------------------------------------------------------------------ |
| { |
| gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered"); |
| |
| if ($metric_spec =~ /user/) |
| { |
| $user_metrics = $TRUE; |
| gp_message ("debug", $subr_name, "m: user_metrics set to TRUE"); |
| } |
| elsif ($metric_spec =~ /system/) |
| { |
| $system_metrics = $TRUE; |
| gp_message ("debug", $subr_name, "m: system_metrics set to TRUE"); |
| } |
| elsif ($metric_spec =~ /wall/) |
| { |
| $wall_metrics = $TRUE; |
| gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE"); |
| } |
| #------------------------------------------------------------------------------ |
| # TBD I don't see why these need to be skipped. Also, should be totalcpu. |
| #------------------------------------------------------------------------------ |
| elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/)) |
| { |
| # skip total thread time and total CPU time |
| gp_message ("debug", $subr_name, "m: skip above"); |
| } |
| elsif (defined ($metric_value{$metric_text})) |
| { |
| gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}"); |
| if ($summary_metrics ne '') |
| { |
| $summary_metrics = $summary_metrics.':'.$metric_spec; |
| gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1"); |
| if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) |
| { |
| $detail_metrics = $detail_metrics.':'.$metric_spec; |
| gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1"); |
| $detail_metrics_system = $detail_metrics_system.':'.$metric_spec; |
| gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1"); |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); |
| } |
| } |
| else |
| { |
| $summary_metrics = $metric_spec; |
| gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2"); |
| if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) |
| { |
| $detail_metrics = $metric_spec; |
| gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2"); |
| $detail_metrics_system = $metric_spec; |
| gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2"); |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); |
| } |
| } |
| gp_message ("debug", $subr_name, " metric $metric_spec added"); |
| } |
| else |
| { |
| gp_message ("debug", $subr_name, "m: no want above metric was a 0 total"); |
| } |
| } |
| } |
| } |
| |
| close METRICS; |
| |
| if ($wall_metrics > 0) |
| { |
| gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics"); |
| $summary_metrics = "e.wall:".$summary_metrics; |
| gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3"); |
| } |
| |
| if ($system_metrics > 0) |
| { |
| gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system"); |
| $summary_metrics = "e.system:".$summary_metrics; |
| $call_metrics = "i.system:".$call_metrics; |
| $detail_metrics_system ='e.system:'.$detail_metrics_system; |
| |
| gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4"); |
| gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics"); |
| gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3"); |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # TBD: e.user and i.user do not always exist!! |
| #------------------------------------------------------------------------------ |
| |
| if ($user_metrics > 0) |
| { |
| gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics"); |
| # Ruud if (!exists ($IMETRICS{"i.user"})){ |
| if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) |
| { |
| $summary_metrics = "e.user:".$summary_metrics; |
| } |
| else |
| { |
| $summary_metrics = "e.user:i.user:".$summary_metrics; |
| } |
| $detail_metrics = "e.user:".$detail_metrics; |
| $detail_metrics_system = "e.user:".$detail_metrics_system; |
| |
| gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5"); |
| gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3"); |
| gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4"); |
| |
| if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) |
| { |
| $call_metrics = "a.user:".$call_metrics; |
| } |
| else |
| { |
| $call_metrics = "a.user:i.user:".$call_metrics; |
| } |
| gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2"); |
| } |
| |
| if ($call_metrics eq "") |
| { |
| $call_metrics = $detail_metrics; |
| |
| gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics "); |
| gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3"); |
| } |
| |
| for my $metric (sort keys %ignored_metrics) |
| { |
| if ($ignored_metrics{$metric}) |
| { |
| gp_message ("debug", $subr_name, "active metric, but ignored: $metric"); |
| } |
| |
| } |
| |
| return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics, |
| $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); |
| |
| } #-- End of subroutine process_metrics_data |
| |
| #------------------------------------------------------------------------------ |
| # Process source lines that are not part of the target function. |
| # |
| # Generate straightforward HTML, but define an anchor based on the source line |
| # number in the list. |
| #------------------------------------------------------------------------------ |
| sub process_non_target_source |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($start_scan, $end_scan, |
| $src_times_regex, $function_regex, $number_of_metrics, |
| $file_contents_ref, $modified_html_ref) = @_; |
| |
| my @file_contents = @{ $file_contents_ref }; |
| my @modified_html = @{ $modified_html_ref }; |
| my $colour_code_line = $FALSE; |
| my $input_line; |
| my $line_id; |
| my $modified_line; |
| |
| #------------------------------------------------------------------------------ |
| # Main loop to parse all of the source code and take action as needed. |
| #------------------------------------------------------------------------------ |
| for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++) |
| { |
| $input_line = $file_contents[$line_no]; |
| |
| #------------------------------------------------------------------------------ |
| # Generate straightforward HTML, but define an anchor based on the source line |
| # number in the list. |
| #------------------------------------------------------------------------------ |
| $line_id = extract_source_line_number ($src_times_regex, |
| $function_regex, |
| $number_of_metrics, |
| $input_line); |
| |
| if ($input_line =~ /$function_regex/) |
| { |
| $colour_code_line = $TRUE; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # We need to replace the "<" symbol in the code by "<". |
| #------------------------------------------------------------------------------ |
| $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; |
| |
| #------------------------------------------------------------------------------ |
| # Add an id. |
| #------------------------------------------------------------------------------ |
| $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; |
| |
| my $coloured_line; |
| if ($colour_code_line) |
| { |
| my $boldface = $TRUE; |
| $coloured_line = color_string ( |
| $input_line, |
| $boldface, |
| $g_html_color_scheme{"non_target_function_name"}); |
| $colour_code_line = $FALSE; |
| $modified_line .= "$coloured_line"; |
| } |
| else |
| { |
| $modified_line .= "$input_line"; |
| } |
| gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line"); |
| push (@modified_html, $modified_line); |
| } |
| |
| return (\@modified_html); |
| |
| } #-- End of subroutine process_non_target_source |
| |
| #------------------------------------------------------------------------------ |
| # This function scans the configuration file and adapts the internal settings |
| # accordingly. |
| # |
| # Errors are stored during the parsing and processing phase. They are printed |
| # at the end and sorted by line number. |
| # |
| # |
| # 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; |
| gp_message ("debug", $subr_name, "target function $routine not found"); |
| |
| $msg = "function $routine not found in $base - " . |
| "links to source code involving this function will not work"; |
| gp_message ("warning", $subr_name, $msg); |
| |
| return ($found_target); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Catch the line number of the last function. |
| #------------------------------------------------------------------------------ |
| if ($start_tracking) |
| { |
| $end_target_source = $#file_contents; |
| } |
| gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); |
| gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); |
| gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source"); |
| |
| #------------------------------------------------------------------------------ |
| # We now have the index range for the function of interest and will parse it. |
| # Since we already handled the first line with the function marker, we start |
| # with the line following. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Find the hot source lines and store them. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "determine the maximum metric values"); |
| for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++) |
| { |
| $input_line = $file_contents[$line_number]; |
| gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line"); |
| |
| if ( $input_line =~ /$hot_lines_regex/ ) |
| { |
| gp_message ("debugXL", $subr_name, " $line_number : found a hot line"); |
| #------------------------------------------------------------------------------ |
| # We found a hot line and the metric fields are stored in $2. We turn this |
| # string into an array and add it as a row to hot_source_lines. |
| #------------------------------------------------------------------------------ |
| $hot_line = $1; |
| $metric_values = $2; |
| |
| gp_message ("debugXL", $subr_name, "hot_line = $hot_line"); |
| gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); |
| |
| my @metrics = split (" ", $metric_values); |
| push (@hot_source_lines, [@metrics]); |
| } |
| gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line"); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Transpose the array with the hot lines. This means each row has all the |
| # values for a metrict and it makes it easier to determine the maximum values. |
| #------------------------------------------------------------------------------ |
| for my $row (keys @hot_source_lines) |
| { |
| my $msg = "row[" . $row . "] ="; |
| for my $col (keys @{$hot_source_lines[$row]}) |
| { |
| $msg .= " $hot_source_lines[$row][$col]"; |
| $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col]; |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Print the maximum metric values found. Each row contains the data for a |
| # different metric. |
| #------------------------------------------------------------------------------ |
| for my $row (keys @transposed_hot_lines) |
| { |
| my $msg = "row[" . $row . "] ="; |
| for my $col (keys @{$transposed_hot_lines[$row]}) |
| { |
| $msg .= " $transposed_hot_lines[$row][$col]"; |
| } |
| gp_message ("debugXL", $subr_name, "hot lines = $msg"); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Determine the maximum value for each metric. |
| #------------------------------------------------------------------------------ |
| for my $row (keys @transposed_hot_lines) |
| { |
| my $max_val = 0; |
| for my $col (keys @{$transposed_hot_lines[$row]}) |
| { |
| $max_val = max ($transposed_hot_lines[$row][$col], $max_val); |
| } |
| #------------------------------------------------------------------------------ |
| # Convert to a floating point number. |
| #------------------------------------------------------------------------------ |
| if ($max_val =~ /$integer_only_regex/) |
| { |
| $max_val = sprintf ("%f", $max_val); |
| } |
| push (@max_metric_values, $max_val); |
| } |
| |
| for my $metric (keys @max_metric_values) |
| { |
| my $msg = "$input_filename max_metric_values[$metric] = " . |
| $max_metric_values[$metric]; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Process those functions that are not the current target. |
| #------------------------------------------------------------------------------ |
| $modified_html_ref = process_non_target_source ($start_all_source, |
| $start_target_source-1, |
| $src_times_regex, |
| $function_regex, |
| $number_of_metrics, |
| \@file_contents, |
| \@modified_html); |
| @modified_html = @{ $modified_html_ref }; |
| |
| #------------------------------------------------------------------------------ |
| # This is the core part to process the information for the target function. |
| #------------------------------------------------------------------------------ |
| gp_message ("debugXL", $subr_name, "parse and process the target source"); |
| $modified_html_ref = process_target_source ($start_target_source, |
| $end_target_source, |
| $routine, |
| \@max_metric_values, |
| $src_times_regex, |
| $function2_regex, |
| $number_of_metrics, |
| \@file_contents, |
| \@modified_html); |
| @modified_html = @{ $modified_html_ref }; |
| |
| if ($end_target_source < $#file_contents) |
| { |
| $modified_html_ref = process_non_target_source ($end_target_source+1, |
| $#file_contents, |
| $src_times_regex, |
| $function_regex, |
| $number_of_metrics, |
| \@file_contents, |
| \@modified_html); |
| @modified_html = @{ $modified_html_ref }; |
| } |
| |
| gp_message ("debug", $subr_name, "completed reading source"); |
| |
| #------------------------------------------------------------------------------ |
| # Add an extra line with diagnostics. |
| # |
| # TBD: The same is done in generate_dis_html but should be done only once. |
| #------------------------------------------------------------------------------ |
| if ($hp_value > 0) |
| { |
| my $rounded_percentage = sprintf ("%.1f", $hp_value); |
| $threshold_line = "<i>The setting for the highlight percentage"; |
| $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 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 |
| |
| #------------------------------------------------------------------------------ |
| # 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 |