| #!/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 bigint; |
| use List::Util qw (max); |
| use Cwd qw (abs_path cwd); |
| use File::Basename; |
| use File::stat; |
| use feature qw (state); |
| use POSIX; |
| use Getopt::Long qw (Configure); |
| |
| #------------------------------------------------------------------------------ |
| # Check as early as possible if the version of Perl used is supported. |
| #------------------------------------------------------------------------------ |
| INIT |
| { |
| my $perl_minimal_version_supported = version->parse ("5.10.0")->normal; |
| my $perl_current_version = version->parse ("$]")->normal; |
| |
| if ($perl_current_version lt $perl_minimal_version_supported) |
| { |
| my $msg; |
| |
| $msg = "Error: minimum Perl release required: "; |
| $msg .= $perl_minimal_version_supported; |
| $msg .= " current: "; |
| $msg .= $perl_current_version; |
| $msg .= "\n"; |
| |
| print $msg; |
| |
| exit (1); |
| } |
| } #-- End of INIT |
| |
| #------------------------------------------------------------------------------ |
| # Poor man's version of a boolean. |
| #------------------------------------------------------------------------------ |
| my $TRUE = 1; |
| my $FALSE = 0; |
| |
| #------------------------------------------------------------------------------ |
| # The total number of functions to be processed. |
| #------------------------------------------------------------------------------ |
| my $g_total_function_count = 0; |
| |
| #------------------------------------------------------------------------------ |
| # Used to ensure correct alignment of columns. |
| #------------------------------------------------------------------------------ |
| my $g_max_length_first_metric; |
| |
| #------------------------------------------------------------------------------ |
| # This variable contains the path used to execute $GP_DISPAY_TEXT. |
| #------------------------------------------------------------------------------ |
| my $g_path_to_tools; |
| |
| #------------------------------------------------------------------------------ |
| # Code debugging flag. |
| #------------------------------------------------------------------------------ |
| my $g_test_code = $FALSE; |
| |
| #------------------------------------------------------------------------------ |
| # GPROFNG commands and files used. |
| #------------------------------------------------------------------------------ |
| my $GP_DISPLAY_TEXT = "gp-display-text"; |
| |
| my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; |
| my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log"; |
| |
| #------------------------------------------------------------------------------ |
| # Global variables. |
| #------------------------------------------------------------------------------ |
| my $g_addressing_mode = "64 bit"; |
| |
| #------------------------------------------------------------------------------ |
| # The global regex section. |
| # |
| # First step towards consolidating all regexes. |
| #------------------------------------------------------------------------------ |
| my $g_less_than_regex = '<'; |
| my $g_html_less_than_regex = '<'; |
| my $g_endbr_inst_regex = 'endbr[32|64]'; |
| my $g_rm_surrounding_spaces_regex = '^\s+|\s+$'; |
| |
| #------------------------------------------------------------------------------ |
| # For consistency, use a global variable. |
| #------------------------------------------------------------------------------ |
| my $g_html_new_line = "<br>"; |
| |
| #------------------------------------------------------------------------------ |
| # These are the regex's used. |
| #------------------------------------------------------------------------------ |
| #------------------------------------------------------------------------------ |
| # Disassembly analysis |
| #------------------------------------------------------------------------------ |
| my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; |
| my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; |
| my $g_function_call_v2_regex = |
| '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; |
| |
| my $g_first_metric; |
| |
| my $binutils_version; |
| my $driver_cmd; |
| my $tool_name; |
| my $version_info; |
| |
| my %g_mapped_cmds = (); |
| |
| #------------------------------------------------------------------------------ |
| # Variables dealing with warnings and errors. Since a message may span |
| # multiple lines (for readability reasons), the number of entries in the |
| # array may not reflect the total number of messages. This is why we use |
| # separate variables for the counts. |
| #------------------------------------------------------------------------------ |
| my @g_error_msgs = (); |
| my @g_warning_msgs = (); |
| my $g_total_error_count = 0; |
| #------------------------------------------------------------------------------ |
| # This count is used in the html_create_warnings_page HTML page to show how |
| # many warning messages there are. Warnings are printed through gp_message(), |
| # but since one warning may span multiple lines, we update a separate counter |
| # that contains the total number of warning messages issued so far. |
| #------------------------------------------------------------------------------ |
| my $g_total_warning_count = 0; |
| my $g_options_printed = $FALSE; |
| my $g_abort_msg = "cannot recover from the error(s)"; |
| |
| #------------------------------------------------------------------------------ |
| # Contains the names that have already been tagged. This is a global |
| # structure because otherwise the code would get much more complicated. |
| #------------------------------------------------------------------------------ |
| my %g_tagged_names = (); |
| |
| #------------------------------------------------------------------------------ |
| # TBD Remove the use of these structures. No longer used. |
| #------------------------------------------------------------------------------ |
| my %g_function_tag_id = (); |
| my $g_context = 5; # Defines the range of scan |
| |
| my $g_default_setting_lang = "en-US.UTF-8"; |
| my %g_exp_dir_meta_data; |
| |
| my $g_html_credits_line; |
| |
| my $g_warn_keyword = "[Warning]"; |
| my $g_error_keyword = "[Error]"; |
| |
| my %g_function_occurrences = (); |
| my %g_map_function_to_index = (); |
| my %g_multi_count_function = (); |
| my %g_function_view_all = (); |
| my @g_full_function_view_table = (); |
| |
| my @g_html_experiment_stats = (); |
| |
| #------------------------------------------------------------------------------ |
| # These structures contain the information printed in the function views. |
| #------------------------------------------------------------------------------ |
| my $g_header_lines; |
| |
| my @g_html_function_name = (); |
| |
| #------------------------------------------------------------------------------ |
| # TBD: This variable may not be needed and replaced by tp_value |
| my $thresh = 0; |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Define the driver command, tool name and version number. |
| #------------------------------------------------------------------------------ |
| $driver_cmd = "gprofng display html"; |
| $tool_name = "gp-display-html"; |
| #$binutils_version = "2.38.50"; |
| $binutils_version = "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 }; |
| |
| $msg = "found " . $g_total_function_count . " functions to process"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| for my $keys (0 .. $#function_info) |
| { |
| for my $fields (keys %{$function_info[$keys]}) |
| { |
| $msg = "$keys $fields $function_info[$keys]{$fields}"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| } |
| |
| for my $i (keys %addressobjtextm) |
| { |
| $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i}; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| |
| $msg = "generate the files with function overviews and the"; |
| $msg .= " callers-callees information"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $script_pc_metrics = generate_function_level_info (\@exp_dir_list, |
| $call_metrics, |
| $summary_metrics, |
| $outputdir, |
| $sort_fields_ref); |
| |
| $msg = "preprocess the files with the function level information"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $ignore_value = preprocess_function_files ( |
| $metric_description_ref, |
| $script_pc_metrics, |
| $outputdir, |
| \@sort_fields); |
| |
| $msg = "for each function, generate a set of files"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = |
| process_function_files (\@exp_dir_list, |
| $executable_name, |
| $time_percentage_multiplier, |
| $summary_metrics, |
| $process_all_functions, |
| $elf_loadobjects_found, |
| $outputdir, |
| \@sort_fields, |
| \@function_info, |
| \%function_address_and_index, |
| \%LINUX_vDSO, |
| \%metric_description, |
| $elf_arch, |
| $base_va_executable, |
| $ARCHIVES_MAP_NAME, |
| $ARCHIVES_MAP_VADDR, |
| \%elf_rats); |
| |
| @function_info = @{ $function_info_ref }; |
| %function_address_info = %{ $function_address_info_ref }; |
| %addressobj_index = %{ $addressobj_index_ref }; |
| |
| #------------------------------------------------------------------------------ |
| # Parse the disassembly information and generate the html files. |
| #------------------------------------------------------------------------------ |
| $msg = "parse the disassembly files and generate the html files"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $ignore_value = parse_dis_files (\$number_of_metrics, |
| \@function_info, |
| \%function_address_and_index, |
| \$outputdir, |
| \%addressobj_index); |
| |
| #------------------------------------------------------------------------------ |
| # Parse the source information and generate the html files. |
| #------------------------------------------------------------------------------ |
| $msg = "parse the source files and generate the html files"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); |
| |
| #------------------------------------------------------------------------------ |
| # Parse the caller-callee information and generate the html files. |
| #------------------------------------------------------------------------------ |
| $msg = "process the caller-callee information and generate the html file"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Generate the caller-callee information. |
| #------------------------------------------------------------------------------ |
| $ignore_value = generate_caller_callee (\$number_of_metrics, |
| \@function_info, |
| \%function_view_structure, |
| \%function_address_info, |
| \%addressobjtextm, |
| \$outputdir); |
| |
| #------------------------------------------------------------------------------ |
| # Parse the calltree information and generate the html files. |
| #------------------------------------------------------------------------------ |
| if ($g_user_settings{"calltree"}{"current_value"} eq "on") |
| { |
| $msg = "process the call tree information and generate the html file"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $ignore_value = process_calltree (\@function_info, |
| \%function_address_info, |
| \%addressobjtextm, |
| $outputdir); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Process the metric values. |
| #------------------------------------------------------------------------------ |
| $msg = "generate the html file with the metrics information"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $ignore_value = process_metrics ($outputdir, |
| \@sort_fields, |
| \%metric_description, |
| \%ignored_metrics); |
| |
| #------------------------------------------------------------------------------ |
| # Generate the function view html files. |
| #------------------------------------------------------------------------------ |
| $msg = "generate the function view html files"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $html_first_metric_file_ref = generate_function_view ( |
| \$outputdir, |
| \$summary_metrics, |
| \$number_of_metrics, |
| \@function_info, |
| \%function_view_structure, |
| \%function_address_info, |
| \@sort_fields, |
| \@exp_dir_list, |
| \%addressobjtextm); |
| |
| $html_first_metric_file = ${ $html_first_metric_file_ref }; |
| |
| $msg = "html_first_metric_file = " . $html_first_metric_file; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| $html_test = ${ generate_home_link ("left") }; |
| $msg = "html_test = " . $html_test; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Unconditionnaly generate the page with the warnings. |
| #------------------------------------------------------------------------------ |
| $ignore_value = html_create_warnings_page (\$outputdir); |
| |
| #------------------------------------------------------------------------------ |
| # Generate the index.html file. |
| #------------------------------------------------------------------------------ |
| $msg = "generate the index.html file"; |
| gp_message ("verbose", $subr_name, $msg); |
| |
| $ignore_value = html_generate_index (\$outputdir, |
| \$html_first_metric_file, |
| \$summary_metrics, |
| \$number_of_metrics, |
| \@function_info, |
| \%function_address_info, |
| \@sort_fields, |
| \@exp_dir_list, |
| \%addressobjtextm, |
| \%metric_description_reversed, |
| \@table_execution_stats); |
| |
| #------------------------------------------------------------------------------ |
| # We're done. In debug mode, print the meta data for the experiment |
| # directories. |
| #------------------------------------------------------------------------------ |
| $ignore_value = print_meta_data_experiments ("debug"); |
| |
| #------------------------------------------------------------------------------ |
| # Before the execution completes, print the warning(s) on the screen. |
| # |
| # Note that this assumes that no additional warnings have been created since |
| # the call to html_create_warnings_page. Otherwise there will be a discrepancy |
| # between what is printed on the screen and shown in the warnings.html page. |
| #------------------------------------------------------------------------------ |
| if (($g_total_warning_count > 0) and ($g_warnings)) |
| { |
| $ignore_value = print_warnings_buffer (); |
| @g_warning_msgs = (); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # This is not supposed to happen, but in case there are any fatal errors that |
| # have not caused the execution to terminate, print them here. |
| #------------------------------------------------------------------------------ |
| if (@g_error_msgs) |
| { |
| $ignore_value = print_errors_buffer (\$g_error_keyword); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # One line message to show where the results can be found. |
| #------------------------------------------------------------------------------ |
| my $results_file = $abs_path_outputdir . "/index.html"; |
| my $prologue_text = "Processing completed - view file $results_file" . |
| " in a browser"; |
| gp_message ("diag", $subr_name, $prologue_text); |
| |
| return (0); |
| |
| } #-- End of subroutine main |
| |
| #------------------------------------------------------------------------------ |
| # If it is not present, add a "/" to the name of the argument. This is |
| # intended to be used for the name of the output directory and makes it |
| # easier to construct pathnames. |
| #------------------------------------------------------------------------------ |
| sub append_forward_slash |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($input_string) = @_; |
| |
| my $length_of_string = length ($input_string); |
| my $return_string = $input_string; |
| |
| if (rindex ($input_string, "/") != $length_of_string-1) |
| { |
| $return_string .= "/"; |
| } |
| |
| return ($return_string); |
| |
| } #-- End of subroutine append_forward_slash |
| |
| #------------------------------------------------------------------------------ |
| # Return a string with a comma separated list of directory names. |
| #------------------------------------------------------------------------------ |
| sub build_pretty_dir_list |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($dir_list_ref) = @_; |
| |
| my @dir_list = @{ $dir_list_ref}; |
| |
| my $pretty_dir_list = join ("\n", @dir_list); |
| |
| return ($pretty_dir_list); |
| |
| } #-- End of subroutine build_pretty_dir_list |
| |
| #------------------------------------------------------------------------------ |
| # Calculate the target address in hex by adding the instruction to the |
| # instruction address. |
| #------------------------------------------------------------------------------ |
| sub calculate_target_hex_address |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($instruction_address, $instruction_offset) = @_; |
| |
| my $dec_branch_target; |
| my $d1; |
| my $d2; |
| my $first_char; |
| my $length_of_string; |
| my $mask; |
| my $msg; |
| my $number_of_fields; |
| my $raw_hex_branch_target; |
| my $result; |
| |
| if ($g_addressing_mode eq "64 bit") |
| { |
| $mask = "0xffffffffffffffff"; |
| $number_of_fields = 16; |
| } |
| else |
| { |
| $msg = "g_addressing_mode = $g_addressing_mode not supported"; |
| gp_message ("abort", $subr_name, $msg); |
| } |
| |
| $length_of_string = length ($instruction_offset); |
| $first_char = lcfirst (substr ($instruction_offset,0,1)); |
| $d1 = bigint::hex ($instruction_offset); |
| $d2 = bigint::hex ($mask); |
| # if ($first_char eq "f") |
| if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields)) |
| { |
| #------------------------------------------------------------------------------ |
| # The offset is negative. Convert to decimal and perform the subtrraction. |
| #------------------------------------------------------------------------------ |
| #------------------------------------------------------------------------------ |
| # XOR the decimal representation and add 1 to the result. |
| #------------------------------------------------------------------------------ |
| $result = ($d1 ^ $d2) + 1; |
| $dec_branch_target = bigint::hex ($instruction_address) - $result; |
| } |
| else |
| { |
| $result = $d1; |
| $dec_branch_target = bigint::hex ($instruction_address) + $result; |
| } |
| #------------------------------------------------------------------------------ |
| # Convert to hexadecimal. |
| #------------------------------------------------------------------------------ |
| $raw_hex_branch_target = sprintf ("%x", $dec_branch_target); |
| |
| return ($raw_hex_branch_target); |
| |
| } #-- End of subroutine calculate_target_hex_address |
| |
| #------------------------------------------------------------------------------ |
| # Sets the absolute path to all commands in array @cmds. |
| # |
| # First, it is checked if the command is in the search path, built-in, or an |
| # alias. If this is not the case, search for it in a couple of locations. |
| # |
| # If this all fails, warning messages are printed, but this is not a hard |
| # error. Yet. Most likely, things will go bad later on. |
| # |
| # The commands and their respective paths are stored in hash "g_mapped_cmds". |
| #------------------------------------------------------------------------------ |
| sub check_and_define_cmds |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($cmds_ref, $search_path_ref) = @_; |
| |
| #------------------------------------------------------------------------------ |
| # Dereference the array addressess first and then store the contents. |
| #------------------------------------------------------------------------------ |
| my @cmds = @{$cmds_ref}; |
| my @search_path = @{$search_path_ref}; |
| |
| my @the_fields = (); |
| |
| my $cmd; |
| my $cmd_found; |
| my $error_code; |
| my $failed_cmd; |
| my $failed_cmds; |
| my $found_match; |
| my $mapped; |
| my $msg; |
| my $no_of_failed_mappings; |
| my $no_of_fields; |
| my $output_cmd; |
| my $target_cmd; |
| my $failed_mapping = $FALSE; |
| my $full_path_cmd; |
| |
| gp_message ("debugXL", $subr_name, "\@cmds = @cmds"); |
| gp_message ("debugXL", $subr_name, "\@search_path = @search_path"); |
| |
| #------------------------------------------------------------------------------ |
| # Search for the command and record the absolute path. In case no such path |
| # can be found, the entry in $g_mapped_cmds is assigned a special value that |
| # will be checked for in the next block. |
| #------------------------------------------------------------------------------ |
| for $cmd (@cmds) |
| { |
| $target_cmd = "(command -v $cmd; echo \$\?)"; |
| |
| ($error_code, $output_cmd) = execute_system_cmd ($target_cmd); |
| |
| if ($error_code != 0) |
| #------------------------------------------------------------------------------ |
| # This is unlikely to happen, since it means the command executed failed. |
| #------------------------------------------------------------------------------ |
| { |
| $msg = "error executing this command: " . $target_cmd; |
| gp_message ("warning", $subr_name, $msg); |
| $msg = "execution continues, but may fail later on"; |
| gp_message ("warning", $subr_name, $msg); |
| |
| $g_total_warning_count++; |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # So far, all is well, but is the target command available? |
| #------------------------------------------------------------------------------ |
| { |
| #------------------------------------------------------------------------------ |
| # The output from the $target_cmd command should contain 2 lines in case the |
| # command has been found. The first line shows the command with the full |
| # path, while the second line has the exit code. |
| # |
| # If the exit code is not zero, the command has not been found. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Split the output at the \n character and check the number of lines as |
| # well as the return code. |
| #------------------------------------------------------------------------------ |
| @the_fields = split ("\n", $output_cmd); |
| $no_of_fields = scalar (@the_fields); |
| $cmd_found = ($the_fields[$no_of_fields-1] == 0 ? $TRUE : $FALSE); |
| |
| #------------------------------------------------------------------------------ |
| # This is unexpected. Throw an assertion error and bail out. |
| #------------------------------------------------------------------------------ |
| if ($no_of_fields > 2) |
| { |
| gp_message ("error", $subr_name, "output from $target_cmd:"); |
| gp_message ("error", $subr_name, $output_cmd); |
| |
| $msg = "the output from $target_cmd has more than 2 lines"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| if ($cmd_found) |
| { |
| $full_path_cmd = $the_fields[0]; |
| #------------------------------------------------------------------------------ |
| # The command is in the search path. Store the full path to the command. |
| #------------------------------------------------------------------------------ |
| $msg = "the $cmd command is in the search path"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $g_mapped_cmds{$cmd} = $full_path_cmd; |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # A best effort to locate the command elsewhere. If found, store the command |
| # with the absolute path included. Otherwise print a warning, but continue. |
| #------------------------------------------------------------------------------ |
| { |
| $msg = "the $cmd command is not in the search path"; |
| $msg .= " - start a best effort search to find it"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $found_match = $FALSE; |
| for my $path (@search_path) |
| { |
| $target_cmd = $path . "/" . $cmd; |
| if (-x $target_cmd) |
| { |
| $msg = "found the command in $path"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $found_match = $TRUE; |
| $g_mapped_cmds{$cmd} = $target_cmd; |
| last; |
| } |
| else |
| { |
| $msg = "failure to find the $cmd command in $path"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| |
| if (not $found_match) |
| { |
| $g_mapped_cmds{$cmd} = "road to nowhere"; |
| $failed_mapping = $TRUE; |
| } |
| } |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Scan the results stored in $g_mapped_cmds and flag errors. |
| #------------------------------------------------------------------------------ |
| $no_of_failed_mappings = 0; |
| $failed_cmds = ""; |
| |
| #------------------------------------------------------------------------------ |
| # Print a warning message before showing the results, that at least one search |
| # has failed. |
| #------------------------------------------------------------------------------ |
| if ($failed_mapping) |
| { |
| $msg = "<br>" . "failure in the verification of the OS commands:"; |
| gp_message ("warning", $subr_name, $msg); |
| } |
| |
| while ( ($cmd, $mapped) = each %g_mapped_cmds) |
| { |
| if ($mapped eq "road to nowhere") |
| { |
| $msg = "cannot find a path for command $cmd"; |
| gp_message ("warning", $subr_name, $msg); |
| gp_message ("debug", $subr_name, $msg); |
| |
| $no_of_failed_mappings++; |
| $failed_cmds .= $cmd; |
| $g_mapped_cmds{$cmd} = $cmd; |
| } |
| else |
| { |
| $msg = "path for the $cmd command is $mapped"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| if ($no_of_failed_mappings != 0) |
| { |
| my $plural_1 = ($no_of_failed_mappings > 1) ? "failures" : "failure"; |
| my $plural_2 = ($no_of_failed_mappings > 1) ? "commands" : "command"; |
| |
| $msg = "encountered $no_of_failed_mappings $plural_1 to locate"; |
| $msg .= " selected " . $plural_2; |
| gp_message ("warning", $subr_name, $msg); |
| gp_message ("debug", $subr_name, $msg); |
| |
| $msg = "execution continues, but may fail later on"; |
| gp_message ("warning", $subr_name, $msg); |
| gp_message ("debug", $subr_name, $msg); |
| |
| $g_total_warning_count++; |
| } |
| |
| return ($no_of_failed_mappings); |
| |
| } #-- End of subroutine check_and_define_cmds |
| |
| #------------------------------------------------------------------------------ |
| # Look for a branch instruction, or the special endbr32/endbr64 instruction |
| # that is also considered to be a branch target. Note that the latter is x86 |
| # specific. |
| #------------------------------------------------------------------------------ |
| sub check_and_proc_dis_branches |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($input_line_ref, $line_no_ref, $branch_target_ref, |
| $extended_branch_target_ref, $branch_target_no_ref_ref) = @_; |
| |
| my $input_line = ${ $input_line_ref }; |
| my $line_no = ${ $line_no_ref }; |
| my %branch_target = %{ $branch_target_ref }; |
| my %extended_branch_target = %{ $extended_branch_target_ref }; |
| my %branch_target_no_ref = %{ $branch_target_no_ref_ref }; |
| |
| my $found_it = $TRUE; |
| my $hex_branch_target; |
| my $instruction_address; |
| my $instruction_offset; |
| my $msg; |
| my $raw_hex_branch_target; |
| |
| if ( ($input_line =~ /$g_branch_regex/) |
| or ($input_line =~ /$g_endbr_regex/)) |
| { |
| if (defined ($3)) |
| { |
| $msg = "found a branch or endbr instruction: " . |
| "\$1 = $1 \$2 = $2 \$3 = $3"; |
| } |
| else |
| { |
| $msg = "found a branch or endbr instruction: " . |
| "\$1 = $1 \$2 = $2"; |
| } |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if (defined ($1)) |
| { |
| #------------------------------------------------------------------------------ |
| # Found a qualifying instruction |
| #------------------------------------------------------------------------------ |
| $instruction_address = $1; |
| if (defined ($3)) |
| { |
| #------------------------------------------------------------------------------ |
| # This must be the branch target and needs to be converted and processed. |
| #------------------------------------------------------------------------------ |
| $instruction_offset = $3; |
| $raw_hex_branch_target = calculate_target_hex_address ( |
| $instruction_address, |
| $instruction_offset); |
| |
| $hex_branch_target = "0x" . $raw_hex_branch_target; |
| $branch_target{$hex_branch_target} = 1; |
| $extended_branch_target{$instruction_address} = |
| $raw_hex_branch_target; |
| } |
| if (defined ($2) and (not defined ($3))) |
| { |
| #------------------------------------------------------------------------------ |
| # Unlike a branch, the endbr32/endbr64 instructions do not have a second field. |
| #------------------------------------------------------------------------------ |
| my $instruction_name = $2; |
| if ($instruction_name =~ /$g_endbr_inst_regex/) |
| { |
| my $msg = "found endbr: $instruction_name " . |
| $instruction_address; |
| gp_message ("debugXL", $subr_name, $msg); |
| $raw_hex_branch_target = $instruction_address; |
| |
| $hex_branch_target = "0x" . $raw_hex_branch_target; |
| $branch_target_no_ref{$instruction_address} = 1; |
| } |
| } |
| } |
| else |
| { |
| #------------------------------------------------------------------------------ |
| # TBD: Perhaps this should be an assertion or alike. |
| #------------------------------------------------------------------------------ |
| $branch_target{"0x0000"} = $FALSE; |
| $msg = "cannot determine branch target"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| else |
| { |
| $found_it = $FALSE; |
| } |
| |
| return (\$found_it, \%branch_target, \%extended_branch_target, |
| \%branch_target_no_ref); |
| |
| } #-- End of subroutine check_and_proc_dis_branches |
| |
| #------------------------------------------------------------------------------ |
| # Check an input line from the disassembly file to include a function call. |
| # If it does, process the line and return the branch target results. |
| #------------------------------------------------------------------------------ |
| sub check_and_proc_dis_func_call |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($input_line_ref, $line_no_ref, $branch_target_ref, |
| $extended_branch_target_ref) = @_; |
| |
| my $input_line = ${ $input_line_ref }; |
| my $line_no = ${ $line_no_ref }; |
| my %branch_target = %{ $branch_target_ref }; |
| my %extended_branch_target = %{ $extended_branch_target_ref }; |
| |
| my $found_it = $TRUE; |
| my $hex_branch_target; |
| my $instruction_address; |
| my $instruction_offset; |
| my $msg; |
| my $raw_hex_branch_target; |
| |
| if ( $input_line =~ /$g_function_call_v2_regex/ ) |
| { |
| $msg = "found a function call - line[$line_no] = $input_line"; |
| gp_message ("debugXL", $subr_name, $msg); |
| if (not defined ($2)) |
| { |
| $msg = "line[$line_no] " . |
| "an instruction address is expected, but not found"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| else |
| { |
| $instruction_address = $2; |
| |
| $msg = "instruction_address = $instruction_address"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if (not defined ($4)) |
| { |
| $msg = "line[$line_no] " . |
| "an address offset is expected, but not found"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| else |
| { |
| $instruction_offset = $4; |
| if ($instruction_offset =~ /[0-9a-fA-F]+/) |
| { |
| $msg = "calculate branch target: " . |
| "instruction_address = $instruction_address"; |
| gp_message ("debugXL", $subr_name, $msg); |
| $msg = "calculate branch target: " . |
| "instruction_offset = $instruction_offset"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # The instruction offset needs to be converted and added to the instruction |
| # address. |
| #------------------------------------------------------------------------------ |
| $raw_hex_branch_target = calculate_target_hex_address ( |
| $instruction_address, |
| $instruction_offset); |
| $hex_branch_target = "0x" . $raw_hex_branch_target; |
| |
| $msg = "calculated hex_branch_target = " . |
| $hex_branch_target; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| $branch_target{$hex_branch_target} = 1; |
| $extended_branch_target{$instruction_address} = |
| $raw_hex_branch_target; |
| |
| $msg = "set branch_target{$hex_branch_target} to 1"; |
| gp_message ("debugXL", $subr_name, $msg); |
| $msg = "added extended_branch_target{$instruction_address}"; |
| $msg .= " = $extended_branch_target{$instruction_address}"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| else |
| { |
| $msg = "line[$line_no] unknown address format"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| } |
| } |
| } |
| else |
| { |
| $found_it = $FALSE; |
| } |
| |
| return (\$found_it, \%branch_target, \%extended_branch_target); |
| |
| } #-- End of subroutine check_and_proc_dis_func_call |
| |
| #------------------------------------------------------------------------------ |
| # Check if the value for the user option given is valid. |
| # |
| # In case the value is valid, the g_user_settings table is updated with the |
| # (new) value. |
| # |
| # Otherwise an error message is pushed into the g_error_msgs buffer. |
| # |
| # The return value is TRUE/FALSE. |
| #------------------------------------------------------------------------------ |
| sub check_and_set_user_option |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($internal_opt_name, $value) = @_; |
| |
| my $msg; |
| my $valid; |
| my $option_value_missing; |
| |
| my $option = $g_user_settings{$internal_opt_name}{"option"}; |
| my $data_type = $g_user_settings{$internal_opt_name}{"data_type"}; |
| my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"}; |
| |
| if (($no_of_args >= 1) and |
| ((not defined ($value)) or (length ($value) == 0))) |
| #------------------------------------------------------------------------------ |
| # If there was no value given, but it is required, flag an error. |
| # There could also be a value, but it might be the empty string. |
| # |
| # Note that that there are currently no options with multiple values. Should |
| # these be introduced, the current check may need to be refined. |
| #------------------------------------------------------------------------------ |
| { |
| $valid = $FALSE; |
| $option_value_missing = $TRUE; |
| } |
| elsif ($no_of_args >= 1) |
| { |
| $option_value_missing = $FALSE; |
| #------------------------------------------------------------------------------ |
| # There is an input value. Check if it is valid and if so, store it. |
| # |
| # Note that we allow the options to be case insensitive. |
| #------------------------------------------------------------------------------ |
| $valid = verify_if_input_is_valid ($value, $data_type); |
| |
| if ($valid) |
| { |
| if (($data_type eq "onoff") or ($data_type eq "size")) |
| { |
| $g_user_settings{$internal_opt_name}{"current_value"} = |
| lc ($value); |
| } |
| else |
| { |
| $g_user_settings{$internal_opt_name}{"current_value"} = $value; |
| } |
| $g_user_settings{$internal_opt_name}{"defined"} = $TRUE; |
| } |
| } |
| |
| return (\$valid, \$option_value_missing); |
| |
| } #-- End of subroutine check_and_set_user_option |
| |
| #------------------------------------------------------------------------------ |
| # Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool |
| # needed to provide the information. If it can not be found, execution is |
| # terminated. |
| # |
| # We first search for this tool in the current execution directory. If it |
| # cannot be found there, use $PATH to try to locate it. |
| #------------------------------------------------------------------------------ |
| sub check_availability_tool |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($location_gp_command_ref) = @_; |
| |
| my $error_code; |
| my $error_occurred; |
| my $gp_path; |
| my $msg; |
| my $output_which_gp_display_text; |
| my $return_value; |
| my $target_cmd; |
| |
| #------------------------------------------------------------------------------ |
| # Get the path to gp-display-text. |
| #------------------------------------------------------------------------------ |
| my ($error_occurred_ref, $gp_path_ref, $return_value_ref) = |
| find_path_to_gp_display_text ($location_gp_command_ref); |
| |
| $error_occurred = ${ $error_occurred_ref}; |
| $gp_path = ${ $gp_path_ref }; |
| $return_value = ${ $return_value_ref}; |
| |
| $msg = "error_occurred = $error_occurred return_value = $return_value"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if (not $error_occurred) |
| #------------------------------------------------------------------------------ |
| # All is well and gp-display-text has been located. |
| #------------------------------------------------------------------------------ |
| { |
| $g_path_to_tools = $return_value; |
| |
| $msg = "located $GP_DISPLAY_TEXT in the execution directory"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "g_path_to_tools = $g_path_to_tools"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| else |
| #------------------------------------------------------------------------------ |
| # Something went wrong, but perhaps we can still continue. Try to find |
| # $GP_DISPLAY_TEXT through the search path. |
| #------------------------------------------------------------------------------ |
| { |
| $msg = $g_html_new_line; |
| $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :"; |
| $msg .= " $return_value"; |
| gp_message ("warning", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Check if we can find $GP_DISPLAY_TEXT in the search path. |
| #------------------------------------------------------------------------------ |
| $msg = "check for $GP_DISPLAY_TEXT to be in the search path"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| gp_message ("warning", $subr_name, $msg); |
| $g_total_warning_count++; |
| |
| $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; |
| |
| ($error_code, $output_which_gp_display_text) = |
| execute_system_cmd ($target_cmd); |
| |
| if ($error_code == 0) |
| { |
| my ($gp_file_name, $gp_path, $suffix_not_used) = |
| fileparse ($output_which_gp_display_text); |
| $g_path_to_tools = $gp_path; |
| |
| $msg = "located $GP_DISPLAY_TEXT in $g_path_to_tools"; |
| gp_message ("warning", $subr_name, $msg); |
| $msg = "this is the version that will be used"; |
| gp_message ("warning", $subr_name, $msg); |
| |
| $msg = "the $GP_DISPLAY_TEXT tool is in the search path"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "g_path_to_tools = $g_path_to_tools"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| else |
| { |
| $msg = "failure to find $GP_DISPLAY_TEXT in the search path"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $g_total_error_count++; |
| |
| gp_message ("abort", $subr_name, $g_abort_msg); |
| } |
| } |
| |
| return (\$g_path_to_tools); |
| |
| } #-- End of subroutine check_availability_tool |
| |
| #------------------------------------------------------------------------------ |
| # This function determines whether load objects are in ELF format. |
| # |
| # Compared to the original code, any input value other than 2 or 3 is rejected |
| # upfront. This not only reduces the nesting level, but also eliminates a |
| # possible bug. |
| # |
| # Also, by isolating the tests for the input files, another nesting level could |
| # be eliminated, further simplifying this still too complex code. |
| #------------------------------------------------------------------------------ |
| sub check_loadobjects_are_elf |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($selected_archive) = @_; |
| |
| my $event_kind_map_regex; |
| $event_kind_map_regex = '^<event kind="map"\s.*vaddr='; |
| $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset='; |
| $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes='; |
| $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$'; |
| |
| my $hostname_current = $local_system_config{"hostname_current"}; |
| my $arch = $local_system_config{"processor"}; |
| my $arch_uname_s = $local_system_config{"kernel_name"}; |
| |
| my $extracted_information; |
| |
| my $elf_magic_number; |
| |
| my $executable_name; |
| my $va_executable_in_hex; |
| |
| my $arch_exp; |
| my $hostname_exp; |
| my $os_exp; |
| my $os_exp_full; |
| |
| my $archives_file; |
| my $rc_b; |
| my $file; |
| my $line; |
| my $msg; |
| my $name; |
| my $name_path; |
| my $foffset; |
| my $vaddr; |
| my $modes; |
| |
| my $path_to_map_file; |
| my $path_to_log_file; |
| |
| #------------------------------------------------------------------------------ |
| # TBD: Parameterize and should be the first experiment directory from the list. |
| #------------------------------------------------------------------------------ |
| $path_to_log_file = |
| $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; |
| $path_to_log_file .= $selected_archive; |
| $path_to_log_file .= "/log.xml"; |
| |
| gp_message ("debug", $subr_name, "hostname_current = $hostname_current"); |
| gp_message ("debug", $subr_name, "arch = $arch"); |
| gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); |
| |
| #------------------------------------------------------------------------------ |
| # TBD |
| # |
| # This check can probably be removed since the presence of the log.xml file is |
| # checked for in an earlier phase. |
| #------------------------------------------------------------------------------ |
| $msg = " - unable to open file $path_to_log_file for reading:"; |
| open (LOG_XML, "<", $path_to_log_file) |
| or die ($subr_name . $msg . " " . $!); |
| |
| $msg = "opened file $path_to_log_file for reading"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| while (<LOG_XML>) |
| { |
| $line = $_; |
| chomp ($line); |
| gp_message ("debugM", $subr_name, "read line: $line"); |
| #------------------------------------------------------------------------------ |
| # Search for the first line starting with "<system". Bail out if found and |
| # parsed. These are two examples: |
| # <system hostname="ruud-vm" arch="x86_64" \ |
| # os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> |
| #------------------------------------------------------------------------------ |
| if ($line =~ /^\s*<system\s+/) |
| { |
| $msg = "selected the following line from the log.xml file:"; |
| gp_message ("debugM", $subr_name, $msg); |
| gp_message ("debugM", $subr_name, "$line"); |
| if ($line =~ /.*\s+hostname="([^"]+)/) |
| { |
| $hostname_exp = $1; |
| $msg = "extracted hostname_exp = " . $hostname_exp; |
| gp_message ("debugM", $subr_name, $msg); |
| } |
| if ($line =~ /.*\s+arch="([^"]+)/) |
| { |
| $arch_exp = $1; |
| $msg = "extracted arch_exp = " . $arch_exp; |
| gp_message ("debugM", $subr_name, $msg); |
| } |
| if ($line =~ /.*\s+os="([^"]+)/) |
| { |
| $os_exp_full = $1; |
| #------------------------------------------------------------------------------ |
| # Capture the first word only. |
| #------------------------------------------------------------------------------ |
| if ($os_exp_full =~ /([^\s]+)/) |
| { |
| $os_exp = $1; |
| } |
| $msg = "extracted os_exp = " . $os_exp; |
| gp_message ("debugM", $subr_name, $msg); |
| } |
| last; |
| } |
| } #-- End of while loop |
| |
| close (LOG_XML); |
| |
| #------------------------------------------------------------------------------ |
| # If the current system is identical to the system used in the experiment, |
| # we can return early. Otherwise we need to dig deeper. |
| # |
| # TBD: How about the other experiment directories?! This needs to be fixed. |
| #------------------------------------------------------------------------------ |
| |
| gp_message ("debug", $subr_name, "completed while loop"); |
| gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp"); |
| gp_message ("debug", $subr_name, "arch_exp = $arch_exp"); |
| gp_message ("debug", $subr_name, "os_exp = $os_exp"); |
| |
| #TBD: THIS DOES NOT CHECK IF ELF IS FOUND! |
| |
| if (($hostname_current eq $hostname_exp) and |
| ($arch eq $arch_exp) and |
| ($arch_uname_s eq $os_exp)) |
| { |
| $msg = "early return: the hostname, architecture and OS match"; |
| $msg .= " the current system"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE"; |
| gp_message ("debug", $subr_name, $msg); |
| # FAKE return ($TRUE); |
| } |
| |
| if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) |
| { |
| $msg = "selected_archive = " . $selected_archive; |
| gp_message ("debug", $subr_name, $msg); |
| for my $i (sort keys |
| %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) |
| { |
| $msg = "stored loadobject " . $i . " "; |
| $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i}; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Check if the selected experiment directory has archived files in ELF format. |
| # If not, use the information in map.xml to get the name of the executable |
| # and the virtual address. |
| #------------------------------------------------------------------------------ |
| |
| if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) |
| { |
| $msg = "the files in directory $selected_archive/archives are in"; |
| $msg .= " ELF format"; |
| gp_message ("debugM", $subr_name, $msg); |
| $msg = "IGNORE THIS AND USE MAP.XML"; |
| gp_message ("debugM", $subr_name, $msg); |
| ## return ($TRUE); |
| } |
| |
| $msg = "the files in directory $selected_archive/archives are not in"; |
| $msg .= " ELF format"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $path_to_map_file = |
| $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; |
| $path_to_map_file .= $selected_archive; |
| $path_to_map_file .= "/map.xml"; |
| |
| $msg = " - unable to open file $path_to_map_file for reading:"; |
| open (MAP_XML, "<", $path_to_map_file) |
| or die ($subr_name . $msg . " " . $!); |
| $msg = "opened file $path_to_map_file for reading"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Scan the map.xml file. We need to find the name of the executable with the |
| # mode set to 0x005. For this entry we have to capture the virtual address. |
| #------------------------------------------------------------------------------ |
| $extracted_information = $FALSE; |
| while (<MAP_XML>) |
| { |
| $line = $_; |
| chomp ($line); |
| gp_message ("debugM", $subr_name, "MAP_XML read line = $line"); |
| #------------------------------------------------------------------------------ |
| # Replaces this way too long line: |
| # if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+. |
| # *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.* |
| # name="(.*)".*>$/) |
| #------------------------------------------------------------------------------ |
| if ($line =~ /$event_kind_map_regex/) |
| { |
| gp_message ("debugM", $subr_name, "target line = $line"); |
| $vaddr = $1; |
| $foffset = $2; |
| $modes = $3; |
| $name_path = $4; |
| $name = get_basename ($name_path); |
| $msg = "extracted vaddr = $vaddr foffset = $foffset"; |
| $msg .= " modes = $modes"; |
| gp_message ("debugM", $subr_name, $msg); |
| $msg = "extracted name_path = $name_path name = $name"; |
| gp_message ("debugM", $subr_name, $msg); |
| # $error_extracting_information = $TRUE; |
| $executable_name = $name; |
| my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); |
| my $hex_VA = sprintf ("0x%016x", $result_VA); |
| $va_executable_in_hex = $hex_VA; |
| |
| $msg = "set executable_name = " . $executable_name; |
| gp_message ("debugM", $subr_name, $msg); |
| $msg = "set va_executable_in_hex = " . $va_executable_in_hex; |
| gp_message ("debugM", $subr_name, $msg); |
| $msg = "result_VA = " . $result_VA; |
| gp_message ("debugM", $subr_name, $msg); |
| $msg = "hex_VA = " . $hex_VA; |
| gp_message ("debugM", $subr_name, $msg); |
| |
| if ($modes eq "005") |
| { |
| $extracted_information = $TRUE; |
| last; |
| } |
| } |
| } |
| |
| close (MAP_XML); |
| |
| if (not $extracted_information) |
| { |
| $msg = "cannot find the necessary information in"; |
| $msg .= " the $path_to_map_file file"; |
| gp_message ("assertion", $subr_name, $msg); |
| } |
| |
| ## $executable_name = $ARCHIVES_MAP_NAME; |
| ## $va_executable_in_hex = $ARCHIVES_MAP_VADDR; |
| |
| return ($executable_name, $va_executable_in_hex); |
| |
| } #-- End of subroutine check_loadobjects_are_elf |
| |
| #------------------------------------------------------------------------------ |
| # Compare the current metric values against the maximum values. Mark the line |
| # if a value is within the percentage defined by $hp_value. |
| #------------------------------------------------------------------------------ |
| sub check_metric_values |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($metric_values, $max_metric_values_ref) = @_; |
| |
| my @max_metric_values = @{ $max_metric_values_ref }; |
| |
| my @current_metrics = (); |
| my $colour_coded_line; |
| my $current_value; |
| my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; |
| my $max_value; |
| my $msg; |
| my $relative_distance; |
| |
| @current_metrics = split (" ", $metric_values); |
| $colour_coded_line = $FALSE; |
| |
| for my $metric (0 .. $#current_metrics) |
| { |
| $current_value = $current_metrics[$metric]; |
| if (exists ($max_metric_values[$metric])) |
| { |
| $max_value = $max_metric_values[$metric]; |
| |
| $msg = "metric = $metric current_value = $current_value"; |
| $msg .= " max_value = $max_value"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if ( ($max_value > 0) and ($current_value > 0) and |
| ($current_value != $max_value) ) |
| { |
| # TBD: abs needed? |
| $msg = "metric = $metric current_value = $current_value"; |
| $msg .= " max_value = $max_value"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| $relative_distance = 1.00 - abs ( |
| ($max_value - $current_value)/$max_value ); |
| |
| $msg = "relative_distance = $relative_distance"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if ($relative_distance >= $hp_value/100.0) |
| { |
| $msg = "metric $metric is within the relative_distance"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| $colour_coded_line = $TRUE; |
| last; |
| } |
| } |
| } |
| } #-- End of loop over metrics |
| |
| return (\$colour_coded_line); |
| |
| } #-- End of subroutine check_metric_values |
| |
| #------------------------------------------------------------------------------ |
| # Check if the system is supported. |
| #------------------------------------------------------------------------------ |
| sub check_support_for_processor |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($machine_ref) = @_; |
| |
| my $machine = ${ $machine_ref }; |
| my $is_supported; |
| |
| if ($machine eq "x86_64") |
| { |
| $is_supported = $TRUE; |
| } |
| else |
| { |
| $is_supported = $FALSE; |
| } |
| |
| return (\$is_supported); |
| |
| } #-- End of subroutine check_support_for_processor |
| |
| #------------------------------------------------------------------------------ |
| # Check the command line options for the occurrence of experiments and make |
| # sure that this list is contigious. No other names are allowed in this list. |
| # |
| # Terminate execution in case of an error. Otherwise remove the experiment |
| # names for ARGV (to make the subsequent parsing easier), and return an array |
| # with the experiment names. |
| # |
| # The following patterns are supposed to be detected: |
| # |
| # <expdir_1> some other word(s) <expdir_2> |
| # <expdir> some other word(s) |
| #------------------------------------------------------------------------------ |
| sub check_the_experiment_list |
| { |
| my $subr_name = get_my_name (); |
| |
| #------------------------------------------------------------------------------ |
| # The name of an experiment directory can contain any non-whitespace |
| # character(s), but has to end with .er, or optionally .er/. Multiple |
| # forward slashes are allowed. |
| #------------------------------------------------------------------------------ |
| my $exp_dir_regex = '^(\S+)(\.er)\/*$'; |
| my $forward_slash_regex = '\/*$'; |
| |
| my $current_value; |
| my @exp_dir_list = (); |
| my $found_experiment = $FALSE; |
| my $found_non_exp = $FALSE; |
| my $msg; |
| my $name_non_exp_dir = ""; |
| my $no_of_experiments = 0; |
| my $no_of_invalid_dirs = 0; |
| my $opt_remainder; |
| my $valid = $TRUE; |
| |
| for my $i (keys @ARGV) |
| { |
| $current_value = $ARGV[$i]; |
| if ($current_value =~ /$exp_dir_regex/) |
| #------------------------------------------------------------------------------ |
| # The current value is an experiment. Remove any trailing forward slashes, |
| # Increment the count, push the value into the array and set the |
| # found_experiment flag to TRUE. |
| #------------------------------------------------------------------------------ |
| { |
| $no_of_experiments += 1; |
| |
| $current_value =~ s/$forward_slash_regex//; |
| push (@exp_dir_list, $current_value); |
| |
| if (not $found_experiment) |
| #------------------------------------------------------------------------------ |
| # Start checking for the next field(s). |
| #------------------------------------------------------------------------------ |
| { |
| $found_experiment = $TRUE; |
| } |
| #------------------------------------------------------------------------------ |
| # We had found non-experiment names and now see another experiment. Time to |
| # bail out of the loop. |
| #------------------------------------------------------------------------------ |
| if ($found_non_exp) |
| { |
| last; |
| } |
| } |
| else |
| { |
| if ($found_experiment) |
| #------------------------------------------------------------------------------ |
| # The current value is not an experiment, but the value of found_experiment |
| # indicates at least one experiment has been seen already. This means that |
| # the list of experiment names is not contiguous and that is a fatal error. |
| #------------------------------------------------------------------------------ |
| { |
| $name_non_exp_dir .= $current_value . " "; |
| $found_non_exp = $TRUE; |
| } |
| } |
| |
| } |
| |
| #------------------------------------------------------------------------------ |
| #------------------------------------------------------------------------------ |
| # Error handling. |
| #------------------------------------------------------------------------------ |
| #------------------------------------------------------------------------------ |
| |
| if ($found_non_exp) |
| #------------------------------------------------------------------------------ |
| # The experiment list is not contiguous. |
| #------------------------------------------------------------------------------ |
| { |
| $valid = $FALSE; |
| $msg = "the list with the experiments is not contiguous:"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" . |
| " appears in a list where experiments are expected"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $g_total_error_count++; |
| } |
| |
| if ($no_of_experiments == 0) |
| #------------------------------------------------------------------------------ |
| # The experiment list is empty. |
| #------------------------------------------------------------------------------ |
| { |
| $valid = $FALSE; |
| $msg = "the experiment list is missing from the options"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $g_total_error_count++; |
| } |
| |
| if (not $valid) |
| #------------------------------------------------------------------------------ |
| # If an error has occurred, print the error(s) and terminate execution. |
| #------------------------------------------------------------------------------ |
| { |
| gp_message ("abort", $subr_name, $g_abort_msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # We now have a list with experiments, but we still need to verify whether they |
| # exist, and if so, are these valid experiments? |
| #------------------------------------------------------------------------------ |
| for my $exp_dir (@exp_dir_list) |
| { |
| $msg = "checking experiment directory $exp_dir"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| if (-d $exp_dir) |
| { |
| $msg = "directory $exp_dir found"; |
| gp_message ("debug", $subr_name, $msg); |
| #------------------------------------------------------------------------------ |
| # Files log.xml and map.xml have to be there. |
| #------------------------------------------------------------------------------ |
| if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) |
| { |
| $msg = "directory $exp_dir appears to be a valid experiment"; |
| $msg .= " directory"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| else |
| { |
| $no_of_invalid_dirs++; |
| $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir; |
| $msg .= "/map.xml missing"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $msg = "directory " . get_basename($exp_dir) . " does not"; |
| $msg .= " appear to be a valid experiment directory"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $g_total_error_count++; |
| } |
| } |
| else |
| { |
| $no_of_invalid_dirs++; |
| $msg = "directory " . get_basename($exp_dir) . " does not exist"; |
| gp_message ("error", $subr_name, $msg); |
| |
| $g_total_error_count++; |
| } |
| } |
| |
| if ($no_of_invalid_dirs > 0) |
| #------------------------------------------------------------------------------ |
| # This is a fatal error, but for now, we can continue to check for more errors. |
| # Even if none more are found, execution is terminated before the data is |
| # generated and processed. In this way we can catch as many errors as |
| # possible. |
| #------------------------------------------------------------------------------ |
| { |
| my $plural_or_single = ($no_of_invalid_dirs == 1) ? |
| "one experiment is" : $no_of_invalid_dirs . " experiments are"; |
| |
| $msg = $plural_or_single . " not valid"; |
| ## gp_message ("abort", $subr_name, $msg); |
| |
| ## $g_total_error_count++; |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Remove the experiments from ARGV and return the array with the experiment |
| # names. Note that these may, or may not be valid, but if invalid, execution |
| # terminates before they are used. |
| #------------------------------------------------------------------------------ |
| for my $i (1 .. $no_of_experiments) |
| { |
| my $poppy = pop (@ARGV); |
| |
| $msg = "popped $poppy from ARGV"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $msg = "ARGV after update = " . join (" ", @ARGV); |
| gp_message ("debug", $subr_name, $msg); |
| } |
| |
| return (\@exp_dir_list); |
| |
| } #-- End of subroutine check_the_experiment_list |
| |
| #------------------------------------------------------------------------------ |
| # Perform multiple checks on the experiment directories. |
| # |
| # TBD: It needs to be investigated whether all of this is really neccesary. |
| #------------------------------------------------------------------------------ |
| sub check_validity_exp_dirs |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($exp_dir_list_ref) = @_; |
| |
| my @exp_dir_list = @{ $exp_dir_list_ref }; |
| |
| my %elf_rats = (); |
| |
| my $dir_not_found = $FALSE; |
| my $missing_dirs = 0; |
| my $invalid_dirs = 0; |
| |
| my $archive_dir_not_empty; |
| my $archives_dir; |
| my $archives_file; |
| my $count_exp_dir_not_elf; |
| my $elf_magic_number; |
| my $first_line; |
| my $msg; |
| |
| my $first_time; |
| my $filename; |
| |
| my $comment; |
| |
| my $selected_archive_has_elf_format; |
| |
| my $selected_archive; |
| my $archive_dir_selected; |
| my $no_of_files_in_selected_archive; |
| |
| #------------------------------------------------------------------------------ |
| # Initialize ELF status to FALSE. |
| #------------------------------------------------------------------------------ |
| ## for my $exp_dir (@exp_dir_list) |
| for my $exp_dir (keys %g_exp_dir_meta_data) |
| { |
| $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; |
| $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; |
| } |
| #------------------------------------------------------------------------------ |
| # Check if the load objects are in ELF format. |
| #------------------------------------------------------------------------------ |
| for my $exp_dir (keys %g_exp_dir_meta_data) |
| { |
| $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; |
| $archives_dir .= $exp_dir . "/archives"; |
| $archive_dir_not_empty = $FALSE; |
| $first_time = $TRUE; |
| $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; |
| $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; |
| |
| $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; |
| $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $msg = "checking $archives_dir"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| while (glob ("$archives_dir/*")) |
| { |
| $filename = get_basename ($_); |
| |
| $msg = "processing file: $filename"; |
| gp_message ("debug", $subr_name, $msg); |
| |
| $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; |
| $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; |
| |
| $archive_dir_not_empty = $TRUE; |
| #------------------------------------------------------------------------------ |
| # Replaces the ELF_RATS part in elf_phdr. |
| # |
| # Challenge: splittable_mrg.c_I0txnOW_Wn5 |
| # |
| # TBD: Store this for each relevant experiment directory. |
| #------------------------------------------------------------------------------ |
| my $last_dot = rindex ($filename,"."); |
| my $underscore_before_dot = $TRUE; |
| my $first_underscore = -1; |
| |
| $msg = "last_dot = $last_dot"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| while ($underscore_before_dot) |
| { |
| $first_underscore = index ($filename, "_", $first_underscore+1); |
| if ($last_dot < $first_underscore) |
| { |
| $underscore_before_dot = $FALSE; |
| } |
| } |
| my $original_name = substr ($filename, 0, $first_underscore); |
| $msg = "stripped archive name: " . $original_name; |
| gp_message ("debug", $subr_name, $msg); |
| if (not exists ($elf_rats{$original_name})) |
| { |
| $elf_rats{$original_name} = [$filename, $exp_dir]; |
| } |
| #------------------------------------------------------------------------------ |
| # We only need to detect the presence of an object once. |
| #------------------------------------------------------------------------------ |
| if ($first_time) |
| { |
| $first_time = $FALSE; |
| $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; |
| $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; |
| $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; |
| |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| } |
| } #-- End of loop over experiment directories |
| |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; |
| $msg = "archive directory " . $exp_dir . "/archives is"; |
| $msg .= " " . ($empty ? "empty" : "not empty"); |
| gp_message ("debug", $subr_name, $msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Verify that all relevant files in the archive directories are in ELF format. |
| #------------------------------------------------------------------------------ |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; |
| if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) |
| { |
| $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; |
| $archives_dir .= $exp_dir . "/archives"; |
| $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir; |
| gp_message ("debug", $subr_name, $msg); |
| #------------------------------------------------------------------------------ |
| # Check if any of the loadobjects is of type ELF. Bail out on the first one |
| # found. The assumption is that all other loadobjects must be of type ELF too |
| # then. |
| #------------------------------------------------------------------------------ |
| for my $aname (sort keys |
| %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) |
| { |
| $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; |
| $filename .= $exp_dir . "/archives/" . $aname; |
| $msg = " - unable to open file $filename for reading:"; |
| open (ARCF,"<", $filename) |
| or die ($subr_name . $msg . " " . $!); |
| |
| $first_line = <ARCF>; |
| close (ARCF); |
| |
| #------------------------------------------------------------------------------ |
| # The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF). |
| # |
| # See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format |
| #------------------------------------------------------------------------------ |
| # if ($first_line =~ /^\177ELF.*/) |
| |
| $elf_magic_number = unpack ('H8', $first_line); |
| if ($elf_magic_number eq "7f454c46") |
| { |
| $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = |
| $TRUE; |
| $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE; |
| last; |
| } |
| } |
| } |
| } |
| |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| $msg = "the loadobjects in the archive in $exp_dir are"; |
| $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? |
| " in" : " not in"; |
| $msg .= " ELF format"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) |
| { |
| $msg = "there are no archived files in " . $exp_dir; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| |
| #------------------------------------------------------------------------------ |
| # If there are archived files and they are not in ELF format, a debug message |
| # is issued. |
| # |
| # TBD: Bail out? |
| #------------------------------------------------------------------------------ |
| $count_exp_dir_not_elf = 0; |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) |
| { |
| $count_exp_dir_not_elf++; |
| } |
| } |
| if ($count_exp_dir_not_elf != 0) |
| { |
| $msg = "there are $count_exp_dir_not_elf experiments with non-ELF"; |
| $msg .= " load objects"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| |
| #------------------------------------------------------------------------------ |
| # Select the experiment directory that is used for the files in the archive. |
| # By default, a directory with archived files is used, but in case this does |
| # not exist, a directory without archived files is selected. Obviously this |
| # needs to be dealt with later on. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # Try the experiments with archived files first. |
| #------------------------------------------------------------------------------ |
| $archive_dir_not_empty = $FALSE; |
| $archive_dir_selected = $FALSE; |
| ## for my $exp_dir (sort @exp_dir_list) |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| $msg = "exp_dir = " . $exp_dir; |
| gp_message ("debugXL", $subr_name, $msg); |
| $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"; |
| $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) |
| { |
| $selected_archive = $exp_dir; |
| $archive_dir_not_empty = $TRUE; |
| $archive_dir_selected = $TRUE; |
| $selected_archive_has_elf_format = |
| ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? |
| $TRUE : $FALSE; |
| last; |
| } |
| } |
| if (not $archive_dir_selected) |
| #------------------------------------------------------------------------------ |
| # None are found and pick the first one without archived files. |
| #------------------------------------------------------------------------------ |
| { |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) |
| { |
| $selected_archive = $exp_dir; |
| $archive_dir_not_empty = $FALSE; |
| $archive_dir_selected = $TRUE; |
| $selected_archive_has_elf_format = $FALSE; |
| last; |
| } |
| } |
| } |
| |
| $msg = "experiment $selected_archive has been selected for"; |
| $msg .= " archive analysis"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "this archive is"; |
| $msg .= $archive_dir_not_empty ? " not empty" : " empty"; |
| gp_message ("debug", $subr_name, $msg); |
| $msg = "this archive is"; |
| $msg .= $selected_archive_has_elf_format ? " in" : " not in"; |
| $msg .= " ELF format"; |
| gp_message ("debug", $subr_name, $msg); |
| #------------------------------------------------------------------------------ |
| # Get the size of the hash that contains the archived files. |
| #------------------------------------------------------------------------------ |
| ## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); |
| |
| $no_of_files_in_selected_archive = |
| $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; |
| |
| $msg = "number of files in archive $selected_archive is"; |
| $msg .= " " . $no_of_files_in_selected_archive; |
| gp_message ("debug", $subr_name, $msg); |
| |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; |
| $msg = "archive directory $exp_dir/archives is"; |
| $msg .= $is_empty ? " empty" : " not empty"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| for my $exp_dir (sort keys %g_exp_dir_meta_data) |
| { |
| if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) |
| { |
| for my $object (sort keys |
| %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) |
| { |
| $msg = $exp_dir . " " . $object . " "; |
| $msg .= |
| $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| } |
| |
| return ($archive_dir_not_empty, $selected_archive, \%elf_rats); |
| |
| } #-- End of subroutine check_validity_exp_dirs |
| |
| #------------------------------------------------------------------------------ |
| # Color the string and optionally mark it boldface. |
| # |
| # For supported colors, see: |
| # https://www.w3schools.com/colors/colors_names.asp |
| #------------------------------------------------------------------------------ |
| sub color_string |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($input_string, $boldface, $color) = @_; |
| |
| my $colored_string; |
| |
| $colored_string = "<font color='" . $color . "'>"; |
| |
| if ($boldface) |
| { |
| $colored_string .= "<b>"; |
| } |
| |
| $colored_string .= $input_string; |
| |
| if ($boldface) |
| { |
| $colored_string .= "</b>"; |
| } |
| $colored_string .= "</font>"; |
| |
| return ($colored_string); |
| |
| } #-- End of subroutine color_string |
| |
| #------------------------------------------------------------------------------ |
| # Generate the array with the info on the experiment(s). |
| #------------------------------------------------------------------------------ |
| sub create_exp_info |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($experiment_dir_list_ref, $experiment_data_ref) = @_; |
| |
| my @experiment_dir_list = @{ $experiment_dir_list_ref }; |
| my @experiment_data = @{ $experiment_data_ref }; |
| |
| my @experiment_stats_html = (); |
| my $experiment_stats_line; |
| my $msg; |
| my $plural; |
| |
| $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; |
| |
| $experiment_stats_line = "<h3>\n"; |
| $experiment_stats_line .= "Full pathnames to the input experiment"; |
| $experiment_stats_line .= $plural . "\n"; |
| $experiment_stats_line .= "</h3>\n"; |
| $experiment_stats_line .= "<pre>\n"; |
| |
| for my $i (0 .. $#experiment_dir_list) |
| { |
| $experiment_stats_line .= $experiment_dir_list[$i] . " (" ; |
| $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n"; |
| } |
| $experiment_stats_line .= "</pre>\n"; |
| |
| push (@experiment_stats_html, $experiment_stats_line); |
| |
| $msg = "experiment_stats_line = " . $experiment_stats_line; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| return (\@experiment_stats_html); |
| |
| } #-- End of subroutine create_exp_info |
| |
| #------------------------------------------------------------------------------ |
| # Trivial function to generate a tag. This has been made a function to ensure |
| # consistency creating tags and also make it easier to change them. |
| #------------------------------------------------------------------------------ |
| sub create_function_tag |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($tag_id) = @_; |
| |
| my $function_tag = "function_tag_" . $tag_id; |
| |
| return ($function_tag); |
| |
| } #-- End of subroutine create_function_tag |
| |
| #------------------------------------------------------------------------------ |
| # Generate and return a string with the credits. Note that this also ends |
| # the HTML formatting controls. |
| #------------------------------------------------------------------------------ |
| sub create_html_credits |
| { |
| my $subr_name = get_my_name (); |
| |
| my $msg; |
| my $the_date; |
| |
| my @months = qw (January February March April May June July |
| August September October November December); |
| |
| my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = |
| localtime (); |
| |
| $year += 1900; |
| |
| $the_date = $months[$mon] . " " . $mday . ", " . $year; |
| |
| $msg = "<i>\n"; |
| $msg .= "Output generated by the $driver_cmd command "; |
| $msg .= "on $the_date "; |
| $msg .= "(GNU binutils version " . $binutils_version . ")"; |
| $msg .= "\n"; |
| $msg .= "</i>"; |
| |
| gp_message ("debug", $subr_name, "the date = $the_date"); |
| |
| return (\$msg); |
| |
| } #-- End of subroutine create_html_credits |
| |
| #------------------------------------------------------------------------------ |
| # Generate a string that contains all the necessary HTML header information, |
| # plus a title. |
| # |
| # See also https://www.w3schools.com for the details on the features used. |
| #------------------------------------------------------------------------------ |
| sub create_html_header |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($title_ref) = @_; |
| |
| my $title = ${ $title_ref }; |
| |
| my $LANG = $g_locale_settings{"LANG"}; |
| my $background_color = $g_html_color_scheme{"background_color_page"}; |
| |
| my $html_header; |
| |
| $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n"; |
| $html_header .= "<html lang=\"$LANG\">\n"; |
| $html_header .= "<head>\n"; |
| $html_header .= "<meta http-equiv=\"content-type\""; |
| $html_header .= " content=\"text/html; charset=iso-8859-1\">\n"; |
| $html_header .= "<title>" . $title . "</title>\n"; |
| $html_header .= "</head>\n"; |
| $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; |
| $html_header .= "<style>\n"; |
| $html_header .= "div.left {\n"; |
| $html_header .= "text-align: left;\n"; |
| $html_header .= "}\n"; |
| $html_header .= "div.right {\n"; |
| $html_header .= "text-align: right;\n"; |
| $html_header .= "}\n"; |
| $html_header .= "div.center {\n"; |
| $html_header .= "text-align: center;\n"; |
| $html_header .= "}\n"; |
| $html_header .= "div.justify {\n"; |
| $html_header .= "text-align: justify;\n"; |
| $html_header .= "}\n"; |
| $html_header .= "</style>"; |
| |
| return (\$html_header); |
| |
| } #-- End of subroutine create_html_header |
| |
| #------------------------------------------------------------------------------ |
| # Create a complete table. |
| #------------------------------------------------------------------------------ |
| sub create_table |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($experiment_data_ref, $table_definition_ref) = @_; |
| |
| my @experiment_data = @{ $experiment_data_ref }; |
| my @table_definition = @{ $table_definition_ref }; |
| |
| my @html_exp_table_data = (); |
| my $html_header_line; |
| my $html_table_line; |
| my $html_end_table; |
| |
| $html_header_line = ${ create_table_header_exp (\@experiment_data) }; |
| |
| push (@html_exp_table_data, $html_header_line); |
| |
| for my $i (sort keys @table_definition) |
| { |
| $html_table_line = ${ |
| create_table_entry_exp (\$table_definition[$i]{"name"}, |
| \$table_definition[$i]{"key"}, |
| \@experiment_data) }; |
| push (@html_exp_table_data, $html_table_line); |
| |
| my $msg = "i = $i html_table_line = $html_table_line"; |
| gp_message ("debugXL", $subr_name, $msg); |
| } |
| |
| $html_end_table = "</table>\n"; |
| push (@html_exp_table_data, $html_end_table); |
| |
| return (\@html_exp_table_data); |
| |
| } #-- End of subroutine create_table |
| |
| #------------------------------------------------------------------------------ |
| # Create one row for the table with experiment info. |
| #------------------------------------------------------------------------------ |
| sub create_table_entry_exp |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_; |
| |
| my $entry_name = ${ $entry_name_ref }; |
| my $key = ${ $key_ref }; |
| my @experiment_data = @{ $experiment_data_ref }; |
| |
| my $html_line; |
| my $msg; |
| |
| $msg = "entry_name = $entry_name key = $key"; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| ## $html_line = "<tr><div class=\"left\"><td><b> "; |
| $html_line = "<tr><div class=\"right\"><td><b> "; |
| $html_line .= $entry_name; |
| $html_line .= " </b></td>"; |
| for my $i (sort keys @experiment_data) |
| { |
| if (exists ($experiment_data[$i]{$key})) |
| { |
| $html_line .= "<td> " . $experiment_data[$i]{$key}; |
| $html_line .= " </td>"; |
| } |
| else |
| { |
| $msg = "experiment_data[$i]{$key} does not exist"; |
| ## gp_message ("assertion", $subr_name, $msg); |
| # TBD: warning or error? |
| gp_message ("warning", $subr_name, $msg); |
| } |
| } |
| $html_line .= "</div></tr>\n"; |
| |
| gp_message ("debugXL", $subr_name, "return html_line = $html_line"); |
| |
| return (\$html_line); |
| |
| } #-- End of subroutine create_table_entry_exp |
| |
| #------------------------------------------------------------------------------ |
| # Create the table header for the experiment info. |
| #------------------------------------------------------------------------------ |
| sub create_table_header_exp |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($experiment_data_ref) = @_; |
| |
| my @experiment_data = @{ $experiment_data_ref }; |
| my $html_header_line; |
| my $msg; |
| |
| $html_header_line = "<style>\n"; |
| $html_header_line .= "table, th, td {\n"; |
| $html_header_line .= "border: 1px solid black;\n"; |
| $html_header_line .= "border-collapse: collapse;\n"; |
| $html_header_line .= "}\n"; |
| $html_header_line .= "</style>\n"; |
| $html_header_line .= "</pre>\n"; |
| $html_header_line .= "<table>\n"; |
| $html_header_line .= "<tr><div class=\"center\"><th></th>"; |
| |
| for my $i (sort keys @experiment_data) |
| { |
| $html_header_line .= "<th> Experiment ID "; |
| $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>"; |
| } |
| $html_header_line .= "</div></tr>\n"; |
| |
| $msg = "html_header_line = " . $html_header_line; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| return (\$html_header_line); |
| |
| } #-- End of subroutine create_table_header_exp |
| |
| #------------------------------------------------------------------------------ |
| # Handle where the output should go. If needed, a directory is created where |
| # the results will go. |
| #------------------------------------------------------------------------------ |
| sub define_the_output_directory |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($define_new_output_dir, $overwrite_output_dir) = @_; |
| |
| my $msg; |
| my $outputdir; |
| |
| #------------------------------------------------------------------------------ |
| # If neither -o or -O are set, find the next number to be used in the name for |
| # the default output directory. |
| #------------------------------------------------------------------------------ |
| if ((not $define_new_output_dir) and (not $overwrite_output_dir)) |
| { |
| my $dir_id = 1; |
| while (-d "er.".$dir_id.".html") |
| { $dir_id++; } |
| $outputdir = "er.".$dir_id.".html"; |
| } |
| |
| if (-d $outputdir) |
| { |
| #------------------------------------------------------------------------------ |
| # The -o option is used, but the directory already exists. |
| #------------------------------------------------------------------------------ |
| if ($define_new_output_dir) |
| { |
| $msg = "directory $outputdir already exists"; |
| gp_message ("error", $subr_name, $msg); |
| $g_total_error_count++; |
| |
| $msg = "use the -O/--overwrite option to overwrite an existing"; |
| $msg .= " directory"; |
| gp_message ("abort", $subr_name, $msg); |
| } |
| #------------------------------------------------------------------------------ |
| # This is a bit risky, so we proceed with caution. The output directory exists, |
| # but it is okay to overwrite it. It is removed here and created again below. |
| #------------------------------------------------------------------------------ |
| elsif ($overwrite_output_dir) |
| { |
| my $target_cmd = $g_mapped_cmds{"rm"}; |
| my $rm_output = qx ($target_cmd -rf $outputdir); |
| my $error_code = ${^CHILD_ERROR_NATIVE}; |
| if ($error_code != 0) |
| { |
| gp_message ("error", $subr_name, $rm_output); |
| $msg = "fatal error when trying to remove " . $outputdir; |
| gp_message ("abort", $subr_name, $msg); |
| } |
| else |
| { |
| $msg = "directory $outputdir has been removed"; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| } |
| } |
| #------------------------------------------------------------------------------ |
| # When we get here, the fatal scenarios have been cleared and the name for |
| # $outputdir is known. Time to create it. |
| #------------------------------------------------------------------------------ |
| if (mkdir ($outputdir, 0777)) |
| { |
| $msg = "created output directory " . $outputdir; |
| gp_message ("debug", $subr_name, $msg); |
| } |
| else |
| { |
| $msg = "a fatal problem occurred when creating directory " . $outputdir; |
| gp_message ("abort", $subr_name, $msg); |
| } |
| |
| return ($outputdir); |
| |
| } #-- End of subroutine define_the_output_directory |
| |
| #------------------------------------------------------------------------------ |
| # Return the virtual address for the load object. |
| # |
| # Note that at this point, $elf_arch is known to be supported. |
| # |
| # TBD: Duplications? |
| #------------------------------------------------------------------------------ |
| sub determine_base_va_address |
| { |
| my $subr_name = get_my_name (); |
| |
| my ($executable_name, $base_va_executable, $loadobj, $routine) = @_; |
| |
| my $msg; |
| my $name_loadobject; |
| my $base_va_address; |
| |
| $msg = "base_va_executable = " . $base_va_executable; |
| gp_message ("debugXL", $subr_name, $msg); |
| $msg = "loadobj = " . $loadobj; |
| gp_message ("debugXL", $subr_name, $msg); |
| $msg = "routine = " . $routine; |
| gp_message ("debugXL", $subr_name, $msg); |
| |
| #------------------------------------------------------------------------------ |
| # Strip the pathname from the load object name. |
| #------------------------------------------------------------------------------ |
| $name_loadobject = get_basename <
|