From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 2041) id B17DC3858D28; Wed, 6 Jul 2022 21:59:45 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org B17DC3858D28 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: quoted-printable From: Vladimir Mezentsev To: bfd-cvs@sourceware.org, gdb-cvs@sourceware.org Subject: [binutils-gdb] gprofng: implement a functional gp-display-html X-Act-Checkin: binutils-gdb X-Git-Author: Ruud van der Pas X-Git-Refname: refs/heads/master X-Git-Oldrev: fb5a4a581d4fbd02ae41e034439872a169e43f0b X-Git-Newrev: 41bbac64c36ffc5a418524be55fde20fad888e11 Message-Id: <20220706215945.B17DC3858D28@sourceware.org> Date: Wed, 6 Jul 2022 21:59:45 +0000 (GMT) X-BeenThere: binutils-cvs@sourceware.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Binutils-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 06 Jul 2022 21:59:45 -0000 https://sourceware.org/git/gitweb.cgi?p=3Dbinutils-gdb.git;h=3D41bbac64c36f= fc5a418524be55fde20fad888e11 commit 41bbac64c36ffc5a418524be55fde20fad888e11 Author: Ruud van der Pas Date: Tue Jun 28 10:37:19 2022 -0700 gprofng: implement a functional gp-display-html =20 This patch enables the first support for the "gprofng display html" com= mand. This command works for C/C++ applications on x86_64. Using one or more = gprofng experiment directories as input, a new directory with html files is cre= ated. Through the index.html file in this directory, the performance results = may be viewed in a browser. =20 gprofng/Changelog: 2022-06-28 Ruud van der Pas =20 * gp-display-html/gp-display-html.in: implement first support f= or x86_64 and C/C++ Diff: --- gprofng/gp-display-html/gp-display-html.in | 14631 +++++++++++++++++++++++= +++- 1 file changed, 14468 insertions(+), 163 deletions(-) diff --git a/gprofng/gp-display-html/gp-display-html.in b/gprofng/gp-displa= y-html/gp-display-html.in index f8fbc244c52..54a87d7a3c7 100644 --- a/gprofng/gp-display-html/gp-display-html.in +++ b/gprofng/gp-display-html/gp-display-html.in @@ -1,5 +1,4 @@ -#!/usr/bin/perl - +#!/usr/bin/env perl # Copyright (C) 2021 Free Software Foundation, Inc. # Contributed by Oracle. # @@ -20,14 +19,34 @@ # Foundation, 51 Franklin Street - Fifth Floor, Boston, # MA 02110-1301, USA. =20 +use strict; +use warnings; +use feature qw (state); +use File::stat; + #-------------------------------------------------------------------------= ----- -# gp-display-html, last updated July 2021 -# -# NOTE: This is a skeleton version. The real code will follow as an update. +# Check as early as possible if the version of Perl used is supported. #-------------------------------------------------------------------------= ----- +INIT +{ + my $perl_minimal_version_supported =3D version->parse ("5.10.0")->normal; + my $perl_current_version =3D version->parse ("$]")->normal; =20 -use strict; -use warnings; + if ($perl_current_version lt $perl_minimal_version_supported) + { + my $msg; + + $msg =3D "Error: minimum Perl release required: "; + $msg .=3D $perl_minimal_version_supported; + $msg .=3D " current: "; + $msg .=3D $perl_current_version; + $msg .=3D "\n"; + + print $msg; + + exit (1); + } +} #-- End of INIT =20 #-------------------------------------------------------------------------= ----- # Poor man's version of a boolean. @@ -35,222 +54,14508 @@ use warnings; my $TRUE =3D 1; my $FALSE =3D 0; =20 +my $g_max_length_first_metric; + +#-------------------------------------------------------------------------= ------ +# Code debugging flag +#-------------------------------------------------------------------------= ------ +my $g_test_code =3D $FALSE; + +#-------------------------------------------------------------------------= ------ +# GPROFNG commands and files used. +#-------------------------------------------------------------------------= ------ +my $GP_DISPLAY_TEXT =3D "gp-display-text"; + +my $g_gp_output_file =3D $GP_DISPLAY_TEXT.".stdout.log"; +my $g_gp_error_logfile =3D $GP_DISPLAY_TEXT.".stderr.log"; + +#-------------------------------------------------------------------------= ----- +# Global variables. +#-------------------------------------------------------------------------= ----- +my $g_addressing_mode =3D "64 bit"; + +#-------------------------------------------------------------------------= ----- +# The global regex section. +# +# First step towards consolidating all regexes. +#-------------------------------------------------------------------------= ----- + my $g_less_than_regex =3D '<'; + my $g_html_less_than_regex =3D '<'; + my $g_endbr_inst_regex =3D 'endbr[32|64]'; + +#-------------------------------------------------------------------------= ----- +# These are the regex's used. +#-------------------------------------------------------------------------= ----- +#-------------------------------------------------------------------------= ----- +# Disassembly analysis +#-------------------------------------------------------------------------= ----- + my $g_branch_regex =3D '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; + my $g_endbr_regex =3D '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; + my $g_function_call_v2_regex =3D '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([= 0-9a-fA-F]+)\s*'; + +#-------------------------------------------------------------------------= ----- +# Convenience. These map the on/off value to $TRUE/$FALSE to make the code +# easier to read. For example: "if ($g_verbose)" as opposed to the follow= ing: +# "if ($verbose_setting eq "on"). +#-------------------------------------------------------------------------= ----- +my $g_verbose; +my $g_warnings; +my $g_quiet; + +my $g_first_metric;=20 + +my $binutils_version; +my $driver_cmd; +my $tool_name; +my $version_info; + +my %g_mapped_cmds =3D (); + +#-------------------------------------------------------------------------= ----- +# TBD All warning messages are collected and are accessible through the ma= in +# page. +#-------------------------------------------------------------------------= ----- +my @g_warning_messages =3D (); + +#-------------------------------------------------------------------------= ----- +# 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 =3D (); + +#-------------------------------------------------------------------------= ----- +# TBD Remove the use of these structures. No longer used. +#-------------------------------------------------------------------------= ----- +my %g_function_tag_id =3D (); +my $g_context =3D 5; # Defines the range of scan + +my $g_default_setting_lang =3D "en-US.UTF-8"; +my %g_exp_dir_meta_data; + +my @g_user_input_errors =3D (); + +my $g_html_credits_line; + +my $g_warn_keyword =3D "Input warning: "; +my $g_error_keyword =3D "Input error: "; + +my %g_function_occurrences =3D (); +my %g_map_function_to_index =3D (); +my %g_multi_count_function =3D (); +my %g_function_view_all =3D (); +my @g_full_function_view_table =3D (); + +my @g_html_experiment_stats =3D (); + +#-------------------------------------------------------------------------= ------ +# These structures contain the information printed in the function views. +#-------------------------------------------------------------------------= ------ +my $g_header_lines; + +my @g_html_function_name =3D (); + +#-------------------------------------------------------------------------= ------ +# TBD: This variable may not be needed and replaced by tp_value +my $thresh =3D 0; +#-------------------------------------------------------------------------= ------ + #-------------------------------------------------------------------------= ------ # Define the driver command, tool name and version number. #-------------------------------------------------------------------------= ------ -my $driver_cmd =3D "gprofng display html"; -my $tool_name =3D "gp-display-html"; -my $binutils_version =3D "BINUTILS_VERSION"; -my $version_info =3D $tool_name . " GNU binutils version " . $binutils= _version; +$driver_cmd =3D "gprofng display html"; +$tool_name =3D "gp-display-html"; +#$binutils_version =3D "2.38.50"; +$binutils_version =3D "BINUTILS_VERSION"; +$version_info =3D $tool_name . " GNU binutils version " . $binutils_ve= rsion; + +#-------------------------------------------------------------------------= ------ + +#-------------------------------------------------------------------------= ------ +# Define several key data structures. +#-------------------------------------------------------------------------= ------ +my %g_user_settings =3D=20 + ( + output =3D> { option =3D> "-o" , no_of_arguments =3D> 1, dat= a_type =3D> "path" , current_value =3D> undef, defined =3D> $FALSE}, + overwrite =3D> { option =3D> "-O" , no_of_arguments =3D> 1, dat= a_type =3D> "path" , current_value =3D> undef, defined =3D> $FALSE}, + calltree =3D> { option =3D> "-ct", no_of_arguments =3D> 1, dat= a_type =3D> "onoff" , current_value =3D> "off" , defined =3D> $FALSE= }, + func_limit =3D> { option =3D> "-fl", no_of_arguments =3D> 1, dat= a_type =3D> "pinteger", current_value =3D> 500 , defined =3D> $FALSE= }, + highlight_percentage =3D> { option =3D> "-hp", no_of_arguments =3D> 1,= data_type =3D> "pfloat" , current_value =3D> 90.0 , defined =3D> $F= ALSE}, + threshold_percentage =3D> { option =3D> "-tp", no_of_arguments =3D> 1,= data_type =3D> "pfloat" , current_value =3D> 100.0 , defined =3D> $F= ALSE}, + default_metrics =3D> { option =3D> "-dm", no_of_arguments =3D> 1, dat= a_type =3D> "onoff" , current_value =3D> "off" , defined =3D> $FALSE= }, + ignore_metrics =3D> { option =3D> "-im", no_of_arguments =3D> 1, dat= a_type =3D> "metric_names", current_value =3D> undef, defined =3D> $FALSE}, + verbose =3D> { option =3D> "--verbose" , no_of_arguments =3D>= 1, data_type =3D> "onoff" , current_value =3D> "off" , defined =3D> $FALS= E}, + warnings =3D> { option =3D> "--warnings" , no_of_arguments =3D= > 1, data_type =3D> "onoff" , current_value =3D> "on" , defined =3D> $FALS= E}, + debug =3D> { option =3D> "--debug" , no_of_arguments =3D> 1= , data_type =3D> "size" , current_value =3D> "off" , defined =3D> $FALSE}, + quiet =3D> { option =3D> "--quiet" , no_of_arguments =3D> 1= , data_type =3D> "onoff" , current_value =3D> "off" , defined =3D> $= FALSE}, + ); + +my %g_debug_size =3D=20 + ( + "on" =3D> $FALSE, + "s" =3D> $FALSE, + "m" =3D> $FALSE, + "l" =3D> $FALSE, + "xl" =3D> $FALSE, + ); + +my %local_system_config =3D + ( + kernel_name =3D> "undefined", + nodename =3D> "undefined", + kernel_release =3D> "undefined", + kernel_version =3D> "undefined", + machine =3D> "undefined", + processor =3D> "undefined", + hardware_platform =3D> "undefined", + operating_system =3D> "undefined", + hostname_current =3D> "undefined", + ); + +# Note that we use single quotes here, because regular expressions wreak h= avoc otherwise. + +my %g_arch_specific_settings =3D + ( + arch_supported =3D> $FALSE, + arch =3D> 'undefined', + regex =3D> 'undefined', + subexp =3D> 'undefined', + linksubexp =3D> 'undefined', + ); + +my %g_locale_settings =3D ( + LANG =3D> "en_US.UTF-8", + decimal_separator =3D> "\\.", + covert_to_dot =3D> $FALSE +); =20 #-------------------------------------------------------------------------= ----- -# This is cosmetic, but helps with the scoping of variables. +# See this page for a nice overview with the colors: +# https://www.w3schools.com/colors/colors_groups.asp #-------------------------------------------------------------------------= ----- =20 - main (); +my %g_html_color_scheme =3D ( + "control_flow" =3D> "Brown", + "target_function_name" =3D> "Red", + "non_target_function_name" =3D> "BlueViolet", + "background_color_hot" =3D> "PeachPuff", + "background_color_lukewarm" =3D> "LemonChiffon", + "link_outside_range" =3D> "Crimson", + "error_message" =3D> "LightPink", + "background_color_page" =3D> "White", +# "background_color_page" =3D> "LightGray", + "background_selected_sort" =3D> "LightSlateGray", + "index" =3D> "Lavender", +); =20 - exit (0); +#-------------------------------------------------------------------------= ----- +# These are the base names for the HTML files that are generated. +#-------------------------------------------------------------------------= ----- +my %g_html_base_file_name =3D ( + "caller_callee" =3D> "caller-callee", + "disassembly" =3D> "dis", + "experiment_info" =3D> "experiment-info", + "function_view" =3D> "function-view-sorted", + "index" =3D> "index", + "source" =3D> "src", + "warnings" =3D> "warnings", +); =20 #-------------------------------------------------------------------------= ----- -# THE SUBROUTINES +# This is cosmetic, but helps with the scoping of variables. #-------------------------------------------------------------------------= ----- + main (); + + exit (0); =20 #-------------------------------------------------------------------------= ----- # This is the driver part of the program. #-------------------------------------------------------------------------= ----- -sub -main +sub main { - my $subr_name =3D "main"; - my $ignore_value;=20 + my $subr_name =3D get_my_name (); =20 #-------------------------------------------------------------------------= ----- -# If no options are given, print the help info and exit. +# The name of the configuration file. #-------------------------------------------------------------------------= ----- - $ignore_value =3D early_scan_specific_options(); + my $rc_file_name =3D ".gp-display-html.rc"; =20 - $ignore_value =3D be_patient ();=20 +#-------------------------------------------------------------------------= ----- +# OS commands executed and search paths. +#-------------------------------------------------------------------------= ----- + my @selected_os_cmds =3D qw (rm mv cat hostname locale which printenv ls= =20 + uname readelf mkdir); + my @search_paths_os_cmds =3D qw (/usr/bin /bin); =20 - return (0); +#-------------------------------------------------------------------------= ----- +# TBD: Eliminate these. +#-------------------------------------------------------------------------= ----- + my $ARCHIVES_MAP_NAME; + my $ARCHIVES_MAP_VADDR; =20 -} #-- End of subroutine main +#-------------------------------------------------------------------------= ----- +# Local structures (hashes and arrays). +#-------------------------------------------------------------------------= ----- + my @exp_dir_list; # List with experiment directories + my @metrics_data; =20 -sub -be_patient -{ - print "Functionality not implemented yet - please stay tuned for updates= \n"; + my %function_address_info =3D (); + my $function_address_info_ref;=20 + + my @function_info =3D (); + my $function_info_ref; + + my %function_address_and_index =3D (); + my $function_address_and_index_ref; + + my %addressobjtextm =3D (); + my $addressobjtextm_ref; =20 -} #-- End of subroutine be_patient + my %addressobj_index =3D (); + my $addressobj_index_ref; + + my %LINUX_vDSO =3D (); + my $LINUX_vDSO_ref; + + my %function_view_structure =3D (); + my $function_view_structure_ref; + + my %elf_rats =3D (); + my $elf_rats_ref; =20 #-------------------------------------------------------------------------= ----- -# Prints the version number and license information. +# Local variables. #-------------------------------------------------------------------------= ----- -sub=20 -print_version_info=20 -{ - print "$version_info\n"; - print "Copyright (C) 2021 Free Software Foundation, Inc.\n"; - print "License GPLv3+: GNU GPL version 3 or later .\n"; - print "This is free software: you are free to change and redistribute it= .\n"; - print "There is NO WARRANTY, to the extent permitted by law.\n"; + my $abs_path_outputdir;=20 + my $archive_dir_not_empty; + my $base_va_executable;=20 + my $executable_name; + my $exp_dir_list_ref; + my $found_exp_dir; + my $ignore_value; + my $message; + my $number_of_metrics; + my $va_executable_in_hex; =20 - return (0); + my $failed_command_mappings;=20 + my $option_errors; + my $total_user_errors; =20 -} #-- End of subroutine print_version_info + my $script_pc_metrics;=20 + my $dir_check_errors; + my $consistency_errors; + my $outputdir; + my $return_code; =20 -#-------------------------------------------------------------------------= ------ -# Print the help overview -#-------------------------------------------------------------------------= ------ -sub=20 -print_help_info=20 -{ - print - "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n". - "\n". - "Process one or more experiments to generate a directory containing an= index.html\n". - "file that can be used to browse the experiment data\n". - "\n". - "Options:\n". - "\n". - " --help print usage information and exit.\n". - " --version print the version number and exit.\n". - " --verbose {on|off} enable (on) or disable (off) verbose mode; the d= efault is \"off\".\n". - "\n". - "\n". - " -o, --output use to store the results in; the= default\n". - " name is ./display..html with the fi= rst number\n". - " not in use; an existing directory is not o= verwritten.\n". - "\n". - " -O, --overwrite use to store the results in a= nd overwrite\n". - " any existing directory with the same na= me; make sure\n". - " that umask is set to the correct access= permissions.\n". - "\n". - " -fl, --func_limit impose a limit on the number of functions= processed;\n". - " this is an integer number; set to 0 to p= rocess all\n". - " functions; the default value is 100.\n". - "\n". - " -ct, --calltree {on|off} enable or disable an html page with a cal= l tree linked\n". - " from the bottom of the first page; defau= lt is off.\n". - "\n". - " -tp, --threshold_percentage provide a percentage of m= etric accountability; the\n". - " inclusion of functions f= or each metric will take\n". - " place in sort order unti= l the percentage has been\n". - " reached.\n". - "\n". - " -dm, --default_metrics {on|off} enable or disable automatic select= ion of metrics\n". - " and use a default set of metrics; = the default is off.\n". - "\n". - " -im, --ignore_metrics ignore the metrics from .\n". - "\n". - " -db, --debug {on|off} enable/disable debug mode; print detailed in= formation to assist with troubleshooting\n". - " or further development of this tool; defaul= t is off.\n". - "\n". - " -q, --quiet {on|off} disable/enable the display of warnings; defau= lt is off.\n". - "\n". - "Environment:\n". - "\n". - "The options can be set in a configuration file called .gp-display-htm= l.rc. This\n". - "file needs to be either in the current directory, or in the home dire= ctory of the user.\n". - "The long name of the option without the leading dashes is supported. = For example calltree\n". - "to enable or disable the call tree. Note that some options take a val= ue. In case the same option\n". - "occurs multiple times in this file, only the last setting encountered= is preserved.\n". - "\n". - "Documentation:\n". - "\n". - "A getting started guide for gprofng is maintained as a Texinfo manual= . If the info and\n". - "gprofng programs are properly installed at your site, the command \"i= nfo gprofng\"\n". - "should give you access to this document.\n". - "\n". - "See also:\n". - "\n". - "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), gp-d= isplay-text(1)\n"; + my $decimal_separator; + my $convert_to_dot; + my $architecture_supported; + my $elf_arch; + my $elf_support; + my $home_dir; + my $elf_loadobjects_found;=20 =20 - return (0); + my $rc_file_paths_ref; + my @rc_file_paths =3D (); + my $rc_file_errors =3D 0; =20 -} #-- End of subroutine print_help_info + my @sort_fields =3D (); + my $summary_metrics; + my $call_metrics; + my $user_metrics; + my $system_metrics; + my $wall_metrics; + my $detail_metrics; + my $detail_metrics_system;=20 + + my $pretty_dir_list;=20 + + my %metric_value =3D (); + my %metric_description =3D (); + my %metric_description_reversed =3D (); + my %metric_found =3D (); + my %ignored_metrics =3D (); + + my $metric_value_ref; + my $metric_description_ref; + my $metric_found_ref; + my $ignored_metrics_ref; + + my @table_execution_stats =3D (); + 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; =20 #-------------------------------------------------------------------------= ----- -# Scan the command line for specific options. +# If no options are given, print the help info and exit. #-------------------------------------------------------------------------= ----- -sub -early_scan_specific_options -{ - my $subr_name =3D "early_scan_specific_options"; + if ($#ARGV =3D=3D -1) + { + $ignore_value =3D print_help_info ();=20 + return (0); + } =20 - my $ignore_value; - my $found_option; - my $option_has_value; - my $option_value; +#-------------------------------------------------------------------------= ----- +# This part is like a preamble. Before we continue we need to figure out = some=20 +# things that are needed later on. +#-------------------------------------------------------------------------= ----- + +#-------------------------------------------------------------------------= ----- +# The very first thing to do is to quickly determine if the user has enabl= ed=20 +# one of the following options and take action accordingly: +# --version, --verbose, --debug, --quiet +# +# This avoids that there is a gap between the start of the execution and t= he +# moment the options are parsed, checked, and interpreted. +# +# When parsing the full command line, these options will be more extensive= ly +# checked and also updated in %g_user_settings + +# Note that a confirmation message, if any, is printed here and not when t= he=20 +# options are parsed and processed. +#-------------------------------------------------------------------------= ----- + + $g_verbose =3D $g_user_settings{"verbose"}{"current_value"} eq "on" ? $= TRUE : $FALSE; + $g_warnings =3D $g_user_settings{"warnings"}{"current_value"} eq "on" ? = $TRUE : $FALSE; + $g_quiet =3D $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TR= UE : $FALSE; =20 - my $verbose_setting =3D $FALSE; - my $debug_setting =3D $FALSE; - my $quiet_setting =3D $FALSE; + $ignore_value =3D early_scan_specific_options (); =20 - $option_has_value =3D $FALSE; - ($found_option, $option_value) =3D find_target_option (\@ARGV, $option_h= as_value, "--version"); - if ($found_option) +#-------------------------------------------------------------------------= ----- +# The next subroutine is executed early to ensure the OS commands we need = are=20 +# available. +# +# This subroutine stores the commands and the full path names as an associ= ative +# array called "g_mapped_cmds". The command is the key and the value is t= he full=20 +# path. For example: ("uname", /usr/bin/uname). +#-------------------------------------------------------------------------= ----- + $failed_command_mappings =3D check_and_define_cmds (\@selected_os_cmds, = \@search_paths_os_cmds); + + if ($failed_command_mappings =3D=3D 0) { - $ignore_value =3D print_version_info (); - exit(0); + gp_message ("debug", $subr_name, "verified the OS commands"); } - $option_has_value =3D $FALSE; - ($found_option, $option_value) =3D find_target_option (\@ARGV, $option_h= as_value, "--help"); - if ($found_option) + else { - $ignore_value =3D print_help_info (); - exit(0); + my $msg =3D "failure in the verification of the OS commands"; + gp_message ("assertion", $subr_name, $msg); } =20 - return (0); +#-------------------------------------------------------------------------= ----- +# Get the home directory and the locations for the configuration file on t= he=20 +# current system. +#-------------------------------------------------------------------------= ----- + ($home_dir, $rc_file_paths_ref) =3D get_home_dir_and_rc_path ($rc_file_n= ame); =20 -} #-- End of subroutine early_scan_specific_options + @rc_file_paths =3D @{ $rc_file_paths_ref }; + gp_message ("debug", $subr_name, "the home directory is $home_dir"); + gp_message ("debugXL", $subr_name, "the search path for the rc file is @= rc_file_paths"); + + $pretty_dir_list =3D build_pretty_dir_list (\@rc_file_paths); =20 #-------------------------------------------------------------------------= ----- -# Scan the command line to see if the specified option is present. +# Get the ball rolling. Parse and interpret the configuration file (if an= y) +# and the command line options. # -# Two types of options are supported: options without value (e.g. --help) = or -# those that are set to "on" or "off". +# If either $rc_file_errors or $total_user_errors, or both, are non-zero it +# means a fatal error has occured. In this case, all error messages are=20 +# printed and execution is terminated. +# +# Note that the verbose, debug, and quiet options can be set in this file. +# It is a deliberate choice to ignore these for now. The assumption is th= at +# the user will not be happy if we ignore the command line settings for a +# while. #-------------------------------------------------------------------------= ----- -sub -find_target_option -{ - my ($command_line_ref, $has_value, $target_option) =3D @_; =20 - my @command_line =3D @{ $command_line_ref }; + gp_message ("debugXL", $subr_name, "processing of the rc file disabled f= or now"); + +# Temporarily disabled print_table_user_settings ("debugXL", "before func= tion process_rc_file"); +# Temporarily disabled +# Temporarily disabled $rc_file_errors =3D process_rc_file ($rc_file_name= , $rc_file_paths_ref); +# Temporarily disabled =20 +# Temporarily disabled if ($rc_file_errors !=3D 0) +# Temporarily disabled { +# Temporarily disabled $message =3D "fatal errors in file $rc_file_na= me encountered"; +# Temporarily disabled gp_message ("debugXL", $subr_name, $message); +# Temporarily disabled } +# Temporarily disabled +# Temporarily disabled print_table_user_settings ("debugXL", "after funct= ion process_rc_file"); + +#-------------------------------------------------------------------------= ----- +# Get the ball rolling. Parse and interpret the options. Some first checks +# are performed. +# +# Instead of bailing out on the first user error, we capture all errors, p= rint +# messages and then bail out. This is more user friendly. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Parse the user options"); + + $total_user_errors =3D 0; =20 - my ($command_line_string) =3D join(" ", @command_line); + ($option_errors, $found_exp_dir, $exp_dir_list_ref) =3D parse_and_check_= user_options ( + \$#ARGV,=20 + \@ARGV); + $total_user_errors +=3D $option_errors; =20 - my $option_value =3D "not set"; - my $found_option =3D $FALSE; +#-------------------------------------------------------------------------= ----- +# Dynamically load the modules needed. If a module is not available, prin= t=20 +# an error message and bail out. +# +# This call replaces the following: +# +# use feature qw (state); +# use List::Util qw (min max); +# use Cwd; +# use File::Basename; +# use File::stat; +# use POSIX; +# use bignum; +# +# Note that this check cannot be done earlier, because in case of a missin= g=20 +# module, the man page would not be generated if the code ends prematurely +# in case the --help and --version options are used.. +#-------------------------------------------------------------------------= ----- + my ($module_errors_ref, $missing_modules_ref) =3D handle_module_availabi= lity (); +=20 + my $module_errors =3D ${ $module_errors_ref }; =20 - if ($command_line_string =3D~ /\s*($target_option)\s*(on|off)*\s*/) + if ($module_errors > 0) { - if ($has_value) + my $msg; + + my $plural_or_single =3D ($module_errors > 1) ? "modules are" : "mod= ule is"; + my @missing_modules =3D @{ $missing_modules_ref }; + + for my $i (0 .. $#missing_modules) { + $msg =3D "module $missing_modules[$i] is missing"; + gp_message ("error", $subr_name, $msg); + } + =20 + $msg =3D $module_errors . " " . $plural_or_single . + "missing - execution is terminated"; + gp_message ("abort", $subr_name, $msg); + } + #-------------------------------------------------------------------------= ----- -# We are looking for this kind if substring: "--verbose on" +# The user options have been taken in. Check for validity and consistency. #-------------------------------------------------------------------------= ----- - if (defined($1) and defined($2)) - { - if ( ($2 eq "on") or ($2 eq "off") ) - { - $found_option =3D $TRUE; - $option_value =3D $2; - } - } + gp_message ("verbose", $subr_name, "Process user options"); + + ($option_errors, $ignored_metrics_ref, $outputdir,=20 + $time_percentage_multiplier, $process_all_functions, + $exp_dir_list_ref) =3D process_user_options ($exp_dir_list_ref); + + @exp_dir_list =3D @{ $exp_dir_list_ref }; + %ignored_metrics =3D %{$ignored_metrics_ref}; + + $total_user_errors +=3D $option_errors; + +#-------------------------------------------------------------------------= ----- +# If no option is given for the output directory, pick a default. Otherwi= se, +# if the output directory exists, wipe it clean in case the -O option is u= sed. +# If not, flag an error because the -o option does not overwrite an existi= ng +# directory. +#-------------------------------------------------------------------------= ----- + if ($total_user_errors =3D=3D 0) + { + ($option_errors, $outputdir) =3D set_up_output_directory (); + $abs_path_outputdir =3D cwd () . "/" . $outputdir; + $total_user_errors +=3D $option_errors; + } + + if ($total_user_errors =3D=3D 0) + { + gp_message ("debug", $subr_name, "the output directory is $outputdir= "); + } + else + { +#-------------------------------------------------------------------------= ----- +# All command line errors and warnings are printed here. +#-------------------------------------------------------------------------= ----- + my $plural_or_single =3D ($total_user_errors > 1) ? "errors have" : = "error has"; + $message =3D $g_error_keyword; + $message .=3D $total_user_errors; + if ($rc_file_errors > 0) + { + $message .=3D " additional"; } - else + $message .=3D " fatal input $plural_or_single been detected:"; + gp_message ("error", $subr_name, $message); + for my $key (keys @g_user_input_errors) { + gp_message ("error", $subr_name, "$g_error_keyword $g_user_inpu= t_errors[$key]"); + } + } + #-------------------------------------------------------------------------= ----- -# We are looking for this kind if substring: "--help" +# Bail out in case fatal errors have occurred. #-------------------------------------------------------------------------= ----- - if (defined($1)) - { - $found_option =3D $TRUE; - } - } + if ( ($rc_file_errors + $total_user_errors) > 0) + { + my $msg =3D "the current values for the user controllable settings"; + print_user_settings ("debug", $msg); + + gp_message ("abort", $subr_name, "execution terminated"); } + else + { + my $msg =3D "after parsing the user options, the final values are"; + print_user_settings ("debug", $msg); =20 - return($found_option, $option_value); +#-------------------------------------------------------------------------= ----- +# TBD: Enable once all planned features have been implemented and tested. +#-------------------------------------------------------------------------= ----- +# Temporarily disabled $msg =3D "the final values for the user contro= llable settings"; +# Temporarily disabled print_table_user_settings ("verbose", $msg); + } =20 -} #-- End of subroutine find_target_option +#-------------------------------------------------------------------------= ----- +# Print a list with the experiment directory names +#-------------------------------------------------------------------------= ----- + $pretty_dir_list =3D build_pretty_dir_list (\@exp_dir_list); + + my $plural =3D ($#exp_dir_list > 0) ? "directories are" : "directory is"; + + gp_message ("verbose", $subr_name, "The experiment " . $plural . ":"); + gp_message ("verbose", $subr_name, $pretty_dir_list); + +#-------------------------------------------------------------------------= ----- +# Set up the first entry with the meta data for the experiments. This fie= ld +# contains the absolute paths to the experiment directories. +#-------------------------------------------------------------------------= ----- + for my $exp_dir (@exp_dir_list) + { + my ($filename, $directory_path, $ignore_suffix) =3D fileparse ($exp_d= ir); + gp_message ("debug", $subr_name, "exp_dir =3D $exp_dir");=20 + gp_message ("debug", $subr_name, "filename =3D $filename");=20 + gp_message ("debug", $subr_name, "directory_path =3D $directory_path"= );=20 + $g_exp_dir_meta_data{$filename}{"directory_path"} =3D $directory_path= ;=20 + } + +#-------------------------------------------------------------------------= ----- +# Check whether the experiment directories are valid. If not, it is a fat= al +# error. +# Upon successful return, one directory has been selected to be used in the +# remainder. This is not always the correct thing to do, but is the same = as +# the original code. In due time this should be addressed though. +#-------------------------------------------------------------------------= ----- + ($dir_check_errors, $archive_dir_not_empty, $selected_archive,=20 + $elf_rats_ref) =3D check_validity_exp_dirs ($exp_dir_list_ref); + + if ($dir_check_errors) + { + gp_message ("abort", $subr_name, "execution terminated"); + } + else + { + gp_message ("verbose", $subr_name, "The experiment directories have = been verified and are valid"); + } + + %elf_rats =3D %{$elf_rats_ref}; + +#-------------------------------------------------------------------------= ------ +# Now that we know the map.xml file(s) are present, we can scan these and = get +# the required information. This includes setting the base virtual addres= s. +#-------------------------------------------------------------------------= ------ + $ignore_value =3D determine_base_virtual_address ($exp_dir_list_ref); + +#-------------------------------------------------------------------------= ----- +# Check whether the experiment directories are consistent. +#-------------------------------------------------------------------------= ----- + ($consistency_errors, $executable_name) =3D verify_consistency_experimen= ts ($exp_dir_list_ref); + + if ($consistency_errors =3D=3D 0) + { + gp_message ("verbose", $subr_name, "The experiment directories are c= onsistent"); + } + else + { + gp_message ("abort", $subr_name, "number of consistency errors detec= ted: $consistency_errors");=20 + } + +#-------------------------------------------------------------------------= ----- +# The directories are consistent. We can now set the base virtual address= of +# the executable. +#-------------------------------------------------------------------------= ----- + $base_va_executable =3D $g_exp_dir_meta_data{$selected_archive}{"va_base= _in_hex"};=20 + + gp_message ("debug", $subr_name, "executable_name =3D $executable_nam= e"); + gp_message ("debug", $subr_name, "selected_archive =3D $selected_archive= "); + gp_message ("debug", $subr_name, "base_va_executable =3D $base_va_execut= able"); + +#-------------------------------------------------------------------------= ----- +# The gp-display-text tool is critical and has to be available in order to= proceed. +#-------------------------------------------------------------------------= ----- + $ignore_value =3D check_availability_tool (); + + ($return_code, $decimal_separator, $convert_to_dot) =3D=20 + determine_decimal_separato= r (); + + if ($return_code =3D=3D 0) + { + my $txt =3D "decimal separator is $decimal_separator " .=20 + "(conversion to dot is " . + ($convert_to_dot =3D=3D $TRUE ? "enabled" : "disabled")."= )"; + gp_message ("debugXL", $subr_name, $txt); + } + else + { + my $msg =3D "the decimal separator can not be determined - set to $d= ecimal_separator"; + gp_message ("warning", $subr_name, $msg); + } + +#-------------------------------------------------------------------------= ----- +# Collect and store the system information. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Collect system information and adapt= settings"); + + $return_code =3D get_system_config_info ();=20 + +#-------------------------------------------------------------------------= ----- +# 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 =3D $local_system_config{hostname_current}; + my $arch_uname_s =3D $local_system_config{kernel_name}; + my $arch_uname =3D $local_system_config{processor}; + + gp_message ("debug", $subr_name, "set hostname_current =3D $hostname_cur= rent"); + gp_message ("debug", $subr_name, "set arch_uname_s =3D $arch_uname_s= "); + gp_message ("debug", $subr_name, "set arch_uname =3D $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) =3D=20 + set_system_specific_variables ($arch_uname, $arch_una= me_s); + + gp_message ("debug", $subr_name, "architecture_supported =3D $architectu= re_supported"); + gp_message ("debug", $subr_name, "elf_arch =3D $elf_arch"); + gp_message ("debug", $subr_name, "elf_support =3D ".($elf_arc= h ? "TRUE" : "FALSE")); + + for my $feature (sort keys %g_arch_specific_settings) + { + gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature}= =3D $g_arch_specific_settings{$feature}"); + } + + $arch =3D $g_arch_specific_settings{"arch"}; + $subexp =3D $g_arch_specific_settings{"subexp"}; + $linksubexp =3D $g_arch_specific_settings{"linksubexp"}; + + $g_locale_settings{"LANG"} =3D get_LANG_setting (); + + gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG =3D $g_= locale_settings{'LANG'}"); + +#-------------------------------------------------------------------------= ----- +# Temporarily reset selected settings since these are not yet implemented. +#-------------------------------------------------------------------------= ----- + $ignore_value =3D reset_selected_settings (); + +#-------------------------------------------------------------------------= ----- +# TBD: Revisit. Is this really necessary? +#-------------------------------------------------------------------------= ----- + + ($executable_name, $va_executable_in_hex) =3D check_loadobjects_are_elf = ($selected_archive); + $elf_loadobjects_found =3D $TRUE; + +# TBD: Hack and those ARCHIVES_ names can be eliminated + $ARCHIVES_MAP_NAME =3D $executable_name; + $ARCHIVES_MAP_VADDR =3D $va_executable_in_hex; + gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME =3D $ARCHIVE= S_MAP_NAME"); + gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR =3D $ARCHIVE= S_MAP_VADDR"); + + gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_= elf forced elf_loadobjects_found =3D $elf_loadobjects_found"); + =20 + $g_html_credits_line =3D ${ create_html_credits () }; + gp_message ("debugXL", $subr_name, "g_html_credits_line =3D $g_html_cred= its_line"); +#-------------------------------------------------------------------------= ----- +# Add a "/" to simplify the construction of path names in the remainder. +# +# TBD: Push this into a subroutine(s). +#-------------------------------------------------------------------------= ----- + $outputdir =3D append_forward_slash ($outputdir); + + gp_message ("debug", $subr_name, "prepared outputdir =3D $outputdir"); + +#-------------------------------------------------------------------------= ----- +#-------------------------------------------------------------------------= ----- +# ******* TBD: e.system not available on Linux!! +#-------------------------------------------------------------------------= ----- +#-------------------------------------------------------------------------= ----- + +## my $summary_metrics =3D 'e.totalcpu'; + $detail_metrics =3D 'e.totalcpu'; + $detail_metrics_system =3D 'e.totalcpu:e.system'; + $call_metrics =3D 'a.totalcpu'; + + my $cmd_options;=20 + my $metrics_cmd; + + my $outfile1 =3D $outputdir ."metrics"; + my $outfile2 =3D $outputdir . "metrictotals"; + my $gp_error_file =3D $outputdir . $g_gp_error_logfile; + +#-------------------------------------------------------------------------= ----- +# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goa= l is +# to get all the output in files $outfile1 and $outfile2. These are then +# parsed. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Gather the metrics data from the exp= eriments"); + + $return_code =3D get_metrics_data (\@exp_dir_list, $outputdir, $outfile1= , $outfile2, $gp_error_file); + + if ($return_code !=3D 0) + { + gp_message ("abort", $subr_name, "execution terminated"); + } + +#-------------------------------------------------------------------------= ----- +# TBD: Test this code +#-------------------------------------------------------------------------= ----- + open (METRICS, "<", $outfile1)=20 + or die ("$subr_name - unable to open metric value data file $outfile1 = for reading: '$!'"); + gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); + + chomp (@metrics_data =3D ); + close (METRICS); + + for my $i (keys @metrics_data) + { + gp_message ("debugXL", $subr_name, "metrics_data[$i] =3D $metrics_da= ta[$i]"); + } + +#-------------------------------------------------------------------------= ----- +# Process the generated metrics data. +#-------------------------------------------------------------------------= ----- + if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") + +#-------------------------------------------------------------------------= ----- +# The metrics will be derived from the experiments. +#-------------------------------------------------------------------------= ----- + { + gp_message ("verbose", $subr_name, "Process the metrics data"); + + ($metric_value_ref, $metric_description_ref, $metric_found_ref,=20 + $user_metrics, $system_metrics, $wall_metrics, + $summary_metrics, $detail_metrics, $detail_metrics_system, $call_me= trics + ) =3D process_metrics_data ($outfile1, $outfile2, \%ignored_metrics= ); + + %metric_value =3D %{ $metric_value_ref }; + %metric_description =3D %{ $metric_description_ref }; + %metric_found =3D %{ $metric_found_ref }; + %metric_description_reversed =3D reverse %metric_description; + + gp_message ("debugXL", $subr_name, "after the call to process_metric= s_data"); + for my $metric (sort keys %metric_value) + { + gp_message ("debugXL", $subr_name, "metric_value{$metric} =3D $m= etric_value{$metric}"); + } + for my $metric (sort keys %metric_description) + { + gp_message ("debugXL", $subr_name, "metric_description{$metric} = =3D $metric_description{$metric}"); + } + gp_message ("debugXL", $subr_name, "user_metrics =3D $user_metrics= "); + gp_message ("debugXL", $subr_name, "system_metrics =3D $system_metri= cs"); + gp_message ("debugXL", $subr_name, "wall_metrics =3D $wall_metrics= "); + } + else + { +#-------------------------------------------------------------------------= ----- +# A default set of metrics will be used. +# +# TBD: These should be OS dependent. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Select the set of default metric= s");=20 + + ($metric_description_ref, $metric_found_ref, $summary_metrics,=20 + $detail_metrics, $detail_metrics_system, $call_metrics + ) =3D set_default_metrics ($outfile1, \%ignored_metrics); + + + %metric_description =3D %{ $metric_description_ref }; + %metric_found =3D %{ $metric_found_ref }; + %metric_description_reversed =3D reverse %metric_description; + + gp_message ("debug", $subr_name, "after the call to set_default_metr= ics"); + + } + + $number_of_metrics =3D split (":", $summary_metrics); + + gp_message ("debugXL", $subr_name, "summary_metrics =3D $summary_m= etrics"); + gp_message ("debugXL", $subr_name, "detail_metrics =3D $detail_me= trics"); + gp_message ("debugXL", $subr_name, "detail_metrics_system =3D $detail_me= trics_system"); + gp_message ("debugXL", $subr_name, "call_metrics =3D $call_metr= ics"); + gp_message ("debugXL", $subr_name, "number_of_metrics =3D $number_of_met= rics"); + +#-------------------------------------------------------------------------= ----- +# TBD Find a way to better handle this situation: +#-------------------------------------------------------------------------= ----- + for my $im (keys %metric_found) + { + gp_message ("debugXL", $subr_name, "metric_found{$im} =3D $metric_fo= und{$im}"); + } + for my $im (keys %ignored_metrics) + { + if (not exists ($metric_found{$im})) + { + gp_message ("debugXL", $subr_name, "user requested ignored metri= c (-im) $im does not exist in collected metrics"); + } + } + +#-------------------------------------------------------------------------= ----- +# Get the information on the experiments. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Generate the experiment information"= ); + =20 + my $exp_info_file_ref; + my $exp_info_file; + my $exp_info_ref; + my @exp_info; + + my $experiment_data_ref; + + $experiment_data_ref =3D get_experiment_info (\$outputdir, \@exp_dir_lis= t); + my @experiment_data =3D @{ $experiment_data_ref }; + + for my $i (sort keys @experiment_data) + { + my $msg =3D "i =3D $i " . $experiment_data[$i]{"exp_id"} . " =3D> " = .=20 + $experiment_data[$i]{"exp_name_full"}; + gp_message ("debugM", $subr_name, $msg); + } + + $experiment_data_ref =3D process_experiment_info ($experiment_data_ref); + @experiment_data =3D @{ $experiment_data_ref }; + + for my $i (sort keys @experiment_data) + { + for my $fields (sort keys %{ $experiment_data[$i] }) + { + my $msg =3D "i =3D $i experiment_data[$i]{$fields} =3D " . + $experiment_data[$i]{$fields}; + gp_message ("debugXL", $subr_name, $msg); + } + } + + @g_html_experiment_stats =3D @{ create_exp_info ( + \@exp_dir_list, + \@experiment_data) }; + + $table_execution_stats_ref =3D html_generate_exp_summary ( + \$outputdir,=20 + \@experiment_data); + @table_execution_stats =3D @{ $table_execution_stats_ref }; + +#-------------------------------------------------------------------------= ----- +# Get the function overview. +#-------------------------------------------------------------------------= ----- + gp_message ("verbose", $subr_name, "Generate the list with functions exe= cuted"); + + my ($outfile, $sort_fields_ref) =3D get_hot_functions (\@exp_dir_list, $= summary_metrics, $outputdir); + + @sort_fields =3D @{$sort_fields_ref}; + +#-------------------------------------------------------------------------= ----- +# Parse the output from the fsummary command and store the relevant data f= or +# all the functions listed there. +#-------------------------------------------------------------------------= ----- + + gp_message ("verbose", $subr_name, "Analyze and store the relevant funct= ion information"); + + ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_r= ef,=20 + $LINUX_vDSO_ref, $function_view_structure_ref) =3D get_function_info ($= outfile); + + @function_info =3D @{ $function_info_ref }; + %function_address_and_index =3D %{ $function_address_and_index_ref }; + %addressobjtextm =3D %{ $addressobjtextm_ref }; + %LINUX_vDSO =3D %{ $LINUX_vDSO_ref }; + %function_view_structure =3D %{ $function_view_structure_ref }; + + for my $keys (0 .. $#function_info) + { + for my $fields (keys %{$function_info[$keys]}) + { + gp_message ("debugXL", $subr_name,"$keys $fields $function_info[= $keys]{$fields}"); + } + } + + for my $i (keys %addressobjtextm) + { + gp_message ("debugXL", $subr_name,"addressobjtextm{$i} =3D $addresso= bjtextm{$i}"); + } + + gp_message ("verbose", $subr_name, "Generate the files with function ove= rviews and the callers-callees information");=20 + + $script_pc_metrics =3D generate_function_level_info (\@exp_dir_list,=20 + $call_metrics,=20 + $summary_metrics,=20 + $outputdir,=20 + $sort_fields_ref); + + gp_message ("verbose", $subr_name, "Preprocess the files with the functi= on level information"); + + $ignore_value =3D preprocess_function_files ( + $metric_description_ref,=20 + $script_pc_metrics,=20 + $outputdir,=20 + \@sort_fields); + + gp_message ("verbose", $subr_name, "For each function, generate a set of= files"); + + ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = =3D process_function_files ( + = \@exp_dir_list, + = $executable_name, + = $time_percentage_multiplier, + = $summary_metrics, + = $process_all_functions, + = $elf_loadobjects_found,=20 + = $outputdir,=20 + = \@sort_fields,=20 + = \@function_info,=20 + = \%function_address_and_index, + = \%LINUX_vDSO, + = \%metric_description, + = $elf_arch, + = $base_va_executable, + = $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats); + + @function_info =3D @{ $function_info_ref }; + %function_address_info =3D %{ $function_address_info_ref }; + %addressobj_index =3D %{ $addressobj_index_ref }; + +#-------------------------------------------------------------------------= ------------ +# Parse the disassembly information and generate the html files. +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Parse the disassembly files and gene= rate the html files"); + + $ignore_value =3D parse_dis_files (\$number_of_metrics, \@function_info,= =20 + \%function_address_and_index, + \$outputdir, \%addressobj_index); + +#-------------------------------------------------------------------------= ------------ +# Parse the source information and generate the html files. +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Parse the source files and generate = the html files"); + + parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); + +#-------------------------------------------------------------------------= ------------ +# Parse the caller-callee information and generate the html files. +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Process the caller-callee informatio= n and generate the html file"); + +#-------------------------------------------------------------------------= ------------ +# Generate the caller-callee information. +#-------------------------------------------------------------------------= ------------ + $ignore_value =3D generate_caller_callee ( + \$number_of_metrics,=20 + \@function_info,=20 + \%function_view_structure, + \%function_address_info,=20 + \%addressobjtextm,=20 + \$outputdir); + +#-------------------------------------------------------------------------= ------------ +# Parse the calltree information and generate the html files. +#-------------------------------------------------------------------------= ------------ + if ($g_user_settings{"calltree"}{"current_value"} eq "on") + { + my $msg =3D "Process the call tree information and generate the html= file"; + gp_message ("verbose", $subr_name, $msg); + + $ignore_value =3D process_calltree ( + \@function_info,=20 + \%function_address_info,=20 + \%addressobjtextm,=20 + $outputdir); + } + +#-------------------------------------------------------------------------= ------------ +# TBD +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Generate the html file with the metr= ics information"); + + $ignore_value =3D process_metrics ( + $outputdir,=20 + \@sort_fields,=20 + \%metric_description,=20 + \%ignored_metrics); + +#-------------------------------------------------------------------------= ------------ +# Generate the function view html files. +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Generate the function view html file= s"); + + $html_first_metric_file_ref =3D generate_function_view ( + \$outputdir,=20 + \$summary_metrics,=20 + \$number_of_metrics,=20 + \@function_info,=20 + \%function_view_structure, + \%function_address_info,=20 + \@sort_fields,=20 + \@exp_dir_list,=20 + \%addressobjtextm); + + $html_first_metric_file =3D ${ $html_first_metric_file_ref }; + + gp_message ("debugXL", $subr_name, "html_first_metric_file =3D $html_fir= st_metric_file"); + + my $html_test =3D ${ generate_home_link ("left") }; + gp_message ("debugXL", $subr_name, "html_test =3D $html_test"); + + my $number_of_warnings_ref =3D create_html_warnings_page (\$outputdir); + +#-------------------------------------------------------------------------= ------------ +# Generate the index.html file. +#-------------------------------------------------------------------------= ------------ + gp_message ("verbose", $subr_name, "Generate the index.html file"); + + $ignore_value =3D generate_index (\$outputdir,=20 + \$html_first_metric_file, + \$summary_metrics,=20 + \$number_of_metrics,=20 + \@function_info,=20 + \%function_address_info,=20 + \@sort_fields,=20 + \@exp_dir_list,=20 + \%addressobjtextm,=20 + \%metric_description_reversed, + $number_of_warnings_ref, + \@table_execution_stats); + +#-------------------------------------------------------------------------= ------------ +# We're done. In debug mode, print the meta data for the experiment direc= tories. +#-------------------------------------------------------------------------= ------------ + $ignore_value =3D print_meta_data_experiments ("debug"); + + my $results_file =3D $abs_path_outputdir . "/index.html"; + my $prologue_text =3D "Processing completed - view file $results_file in= a browser"; + gp_message ("diag", $subr_name, $prologue_text); + + return (0); + +} #-- End of subroutine main + +#-------------------------------------------------------------------------= ----- +# Print a message after a failure in $GP_DISPLAY_TEXT. +#-------------------------------------------------------------------------= ----- +sub msg_display_text_failure +{ + my $subr_name =3D get_my_name (); + + my ($gp_display_text_cmd, $error_code, $error_file) =3D @_; + + my $msg; + + $msg =3D "error code =3D $error_code - failure executing the following c= ommand:"; + gp_message ("error", $subr_name, $msg); + + gp_message ("error", $subr_name, $gp_display_text_cmd); + + $msg =3D "check file $error_file for more details"; + gp_message ("error", $subr_name, $msg); + + return (0); + +} #-- End of subroutine msg_display_text_failure + +#-------------------------------------------------------------------------= ----- +# If it is not present, add a "/" to the name of the argument. This is +# intended to be used for the name of the output directory and makes it=20 +# easier to construct pathnames. +#-------------------------------------------------------------------------= ----- +sub append_forward_slash +{ + my $subr_name =3D get_my_name (); + + my ($input_string) =3D @_; + + my $length_of_string =3D length ($input_string); + my $return_string =3D $input_string; + + if (rindex ($input_string, "/") !=3D $length_of_string-1)=20 + { + $return_string .=3D "/"; + } + + 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 =3D get_my_name (); + + my ($dir_list_ref) =3D @_; + + my @dir_list =3D @{ $dir_list_ref}; + + my $pretty_dir_list =3D 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=20 +# instruction address. +#-------------------------------------------------------------------------= ----- +sub calculate_target_hex_address +{ + my $subr_name =3D get_my_name (); + + my ($instruction_address, $instruction_offset) =3D @_; + + my $dec_branch_target;=20 + my $d1; + my $d2; + my $first_char; + my $length_of_string; + my $mask; + my $number_of_fields; + my $raw_hex_branch_target;=20 + my $result; + + if ($g_addressing_mode eq "64 bit") + { + $mask =3D "0xffffffffffffffff"; + $number_of_fields =3D 16; + } + else + { + gp_message ("abort", $subr_name, "g_addressing_mode =3D $g_addressin= g_mode not supported\n"); + } + =20 + $length_of_string =3D length ($instruction_offset);=20 + $first_char =3D lcfirst (substr ($instruction_offset,0,1)); + $d1 =3D hex ($instruction_offset); + $d2 =3D hex ($mask); +# if ($first_char eq "f") + if (($first_char =3D~ /[89a-f]/) and ($length_of_string =3D=3D $number_o= f_fields)) + { +#-------------------------------------------------------------------------= ----- +# The offset is negative. Convert to decimal and perform the subtrraction. +#-------------------------------------------------------------------------= ----- +#-------------------------------------------------------------------------= ----- +# XOR the decimal representation and add 1 to the result. +#-------------------------------------------------------------------------= ----- + $result =3D ($d1 ^ $d2) + 1; + $dec_branch_target =3D hex ($instruction_address) - $result; + } + else + { + $result =3D $d1; + $dec_branch_target =3D hex ($instruction_address) + $result; + } +#-------------------------------------------------------------------------= ----- +# Convert to hexadecimal. +#-------------------------------------------------------------------------= ----- + $raw_hex_branch_target =3D sprintf ("%x", $dec_branch_target); + + return ($raw_hex_branch_target); + +} #-- End of subroutine calculate_target_hex_address + +#-------------------------------------------------------------------------= ----- +# This subroutine sets the absolute path to all commands in array @cmds. = The +# commands and their respective paths are stored in hash "g_mapped_cmds". +# +# It is a fatal error if such a path can't be found. +#-------------------------------------------------------------------------= ----- +sub check_and_define_cmds +{ + my $subr_name =3D get_my_name (); + + my ($cmds_ref, $search_path_ref) =3D @_; + +#-------------------------------------------------------------------------= ----- +# Dereference the array addressess first and then store the contents. +#-------------------------------------------------------------------------= ----- + my @cmds =3D @{$cmds_ref}; + my @search_path =3D @{$search_path_ref}; + + my $found_match; + my $target_cmd;=20 + my $failed_cmd;=20 + my $no_of_failed_mappings;=20 + my $failed_cmds; + + gp_message ("debug", $subr_name, "\@cmds =3D @cmds"); + gp_message ("debug", $subr_name, "\@search_path =3D @search_path"); + +#-------------------------------------------------------------------------= ----- +# Search for the command to be in the search path given. In case no such = path +# can be found, the entry in $g_mapped_cmds is assigned a special value th= at +# will be checked for in the next block. +#-------------------------------------------------------------------------= ----- + for my $cmd (@cmds) + { + $found_match =3D $FALSE; + for my $path (@search_path) + { + $target_cmd =3D $path."/".$cmd;=20 + if (-x $target_cmd) + { + $found_match =3D $TRUE; + $g_mapped_cmds{$cmd} =3D $target_cmd; + last; + } + } + + if (not $found_match) + { + $g_mapped_cmds{$cmd} =3D "road_to_nowhere"; + } + } + +#-------------------------------------------------------------------------= ----- +# Scan the results stored in $g_mapped_cmds and flag errors. +#-------------------------------------------------------------------------= ----- + $no_of_failed_mappings =3D 0; + $failed_cmds =3D ""; + while ( my ($cmd, $mapped) =3D each %g_mapped_cmds) + { + if ($mapped eq "road_to_nowhere") + { + gp_message ("error", $subr_name, "cannot find a path for command= $cmd"); + $no_of_failed_mappings++;=20 + $failed_cmds .=3D $cmd;=20 + } + else + { + gp_message ("debug", $subr_name, "path for the $cmd command is $= mapped"); + } + } + if ($no_of_failed_mappings !=3D 0) + { + gp_message ("error", $subr_name, "failed to find a mapping for $fail= ed_cmds"); + gp_message ("error", $subr_name, "a total of $no_of_failed_mappings = mapping failures"); + } + + return ($no_of_failed_mappings); + +} #-- End of subroutine check_and_define_cmds + +#-------------------------------------------------------------------------= ----- +# Look for a branch instruction, or the special endbr32/endbr64 instruction +# that is also considered to be a branch target. Note that the latter is = x86 +# specific. +#-------------------------------------------------------------------------= ----- +sub check_and_proc_dis_branches +{ + my $subr_name =3D get_my_name (); + + my ($input_line_ref, $line_no_ref, $branch_target_ref, + $extended_branch_target_ref, $branch_target_no_ref_ref) =3D @_; + + my $input_line =3D ${ $input_line_ref }; + my $line_no =3D ${ $line_no_ref }; + my %branch_target =3D %{ $branch_target_ref }; + my %extended_branch_target =3D %{ $extended_branch_target_ref }; + my %branch_target_no_ref =3D %{ $branch_target_no_ref_ref }; + + my $found_it =3D $TRUE; + my $hex_branch_target; + my $instruction_address; + my $instruction_offset; + my $msg; + my $raw_hex_branch_target; + + if ( ($input_line =3D~ /$g_branch_regex/)=20 + or ($input_line =3D~ /$g_endbr_regex/)) + { + if (defined ($3)) + { + $msg =3D "found a branch or endbr instruction: " . + "\$1 =3D $1 \$2 =3D $2 \$3 =3D $3"; + } + else + { + $msg =3D "found a branch or endbr instruction: " . + "\$1 =3D $1 \$2 =3D $2"; + } + gp_message ("debugXL", $subr_name, $msg); + + if (defined ($1)) + { +#-------------------------------------------------------------------------= ----- +# Found a qualifying instruction +#-------------------------------------------------------------------------= ----- + $instruction_address =3D $1; + if (defined ($3)) + { +#-------------------------------------------------------------------------= ----- +# This must be the branch target and needs to be converted and processed. +#-------------------------------------------------------------------------= ----- + $instruction_offset =3D $3; + $raw_hex_branch_target =3D calculate_target_hex_address ( + $instruction_address,=20 + $instruction_offset);=20 + + $hex_branch_target =3D "0x" . $raw_hex_branch_target; + $branch_target{$hex_branch_target} =3D 1; + $extended_branch_target{$instruction_address} =3D $raw_hex_b= ranch_target; + } + if (defined ($2) and (not defined ($3))) + { +#-------------------------------------------------------------------------= ----- +# Unlike a branch, the endbr32/endbr64 instructions do not have a second f= ield. +#-------------------------------------------------------------------------= ----- + my $instruction_name =3D $2; + if ($instruction_name =3D~ /$g_endbr_inst_regex/) + { + my $msg =3D "found endbr: $instruction_name " . + $instruction_address; + gp_message ("debugXL", $subr_name, $msg); + $raw_hex_branch_target =3D $instruction_address; + + $hex_branch_target =3D "0x" . $raw_hex_branch_target; + $branch_target_no_ref{$instruction_address} =3D 1; + } + } + } + else + { +#-------------------------------------------------------------------------= ----- +# TBD: Perhaps this should be an assertion or alike. +#-------------------------------------------------------------------------= ----- + $branch_target{"0x0000"} =3D $FALSE; + gp_message ("debug", $subr_name, "cannot determine branch target= "); + } + } + else + { + $found_it =3D $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 =3D get_my_name (); + + my ($input_line_ref, $line_no_ref, $branch_target_ref, + $extended_branch_target_ref) =3D @_; + + my $input_line =3D ${ $input_line_ref }; + my $line_no =3D ${ $line_no_ref }; + my %branch_target =3D %{ $branch_target_ref }; + my %extended_branch_target =3D %{ $extended_branch_target_ref }; + + my $found_it =3D $TRUE; + my $hex_branch_target;=20 + my $instruction_address; + my $instruction_offset; + my $msg; + my $raw_hex_branch_target;=20 + + if ( $input_line =3D~ /$g_function_call_v2_regex/ ) + { + $msg =3D "found a function call - line[$line_no] =3D $input_line"; + gp_message ("debugXL", $subr_name, $msg); + if (not defined ($2)) + { + $msg =3D "line[$line_no] " . + "an instruction address is expected, but not found"; + gp_message ("assertion", $subr_name, $msg); + } + else + { + $instruction_address =3D $2; + + $msg =3D "instruction_address =3D $instruction_address"; + gp_message ("debugXL", $subr_name, $msg); + + if (not defined ($4)) + { + $msg =3D "line[$line_no] " . + "an address offset is expected, but not found"; + gp_message ("assertion", $subr_name, $msg); + } + else + { + $instruction_offset =3D $4; + if ($instruction_offset =3D~ /[0-9a-fA-F]+/) + { + $msg =3D "calculate branch target: " . + "instruction_address =3D $instruction_address"; + gp_message ("debugXL", $subr_name, $msg); + $msg =3D "calculate branch target: " . + "instruction_offset =3D $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 =3D calculate_target_hex_address ( + $instruction_address,=20 + $instruction_offset);=20 + $hex_branch_target =3D "0x" . $raw_hex_branch_target; + + $msg =3D "calculated hex_branch_target =3D " . + $hex_branch_target; + gp_message ("debugXL", $subr_name, $msg); + + $branch_target{$hex_branch_target} =3D 1; + $extended_branch_target{$instruction_address} =3D $raw_h= ex_branch_target; + + $msg =3D "set branch_target{$hex_branch_target} to 1"; + gp_message ("debugXL", $subr_name, $msg); + $msg =3D "added extended_branch_target{$instruction_add= ress}" . + " =3D $extended_branch_target{$instruction_addre= ss}"; + gp_message ("debugXL", $subr_name, $msg); + } + else + { + $msg =3D "line[$line_no] unknown address format"; + gp_message ("assertion", $subr_name, $msg); + } + } + } + } + else + { + $found_it =3D $FALSE; + } + + return (\$found_it, \%branch_target, \%extended_branch_target); + +} #-- End of subroutine check_and_proc_dis_func_call + +#-------------------------------------------------------------------------= ----- +# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical= tool=20 +# needed to provide the information. If it can not be found, execution is= =20 +# terminated. +#-------------------------------------------------------------------------= ----- +sub check_availability_tool +{ + my $subr_name =3D get_my_name (); + + my $target_cmd; + my $output_which_gp_display_text; + my $error_code; + + $target_cmd =3D $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; + + ($error_code, $output_which_gp_display_text) =3D execute_system_cmd ($ta= rget_cmd); + =20 + if ($error_code =3D=3D 0) + { + gp_message ("debug", $subr_name, "tool $GP_DISPLAY_TEXT is in the se= arch path"); + }=20 + else + { + gp_message ("abort", $subr_name, "fatal error executing command $tar= get_cmd"); + } + + return (0); + +} #-- 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 reje= cted +# upfront. This not only reduces the nesting level, but also eliminates a= =20 +# 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 =3D get_my_name (); + + my ($selected_archive) =3D @_; + + my $hostname_current =3D $local_system_config{"hostname_current"}; + my $arch =3D $local_system_config{"processor"}; + my $arch_uname_s =3D $local_system_config{"kernel_name"}; + + my $extracted_information;=20 + + my $elf_magic_number; + + my $executable_name; + my $va_executable_in_hex; +=20 + my $arch_exp; + my $hostname_exp; + my $os_exp; + my $os_exp_full; + + my $archives_file; + my $rc_b; + my $file; + my $line; + my $name; + my $name_path; + my $foffset; + my $vaddr; + my $modes; + + my $path_to_map_file;=20 + my $path_to_log_file; + +#-------------------------------------------------------------------------= ----- +# TBD: Parameterize and should be the first experiment directory from the = list. +#-------------------------------------------------------------------------= ----- + $path_to_log_file =3D $g_exp_dir_meta_data{$selected_archive}{"director= y_path"};=20 + $path_to_log_file .=3D $selected_archive; + $path_to_log_file .=3D "/log.xml"; + + gp_message ("debug", $subr_name, "hostname_current =3D $hostname_current= "); + gp_message ("debug", $subr_name, "arch =3D $arch"); + gp_message ("debug", $subr_name, "arch_uname_s =3D $arch_uname_s"); + +#-------------------------------------------------------------------------= ----- +# TBD +# +# This check can probably be removed since the presence of the log.xml fil= e is +# checked for in an earlier phase. +#-------------------------------------------------------------------------= ----- + open (LOG_XML, "<", $path_to_log_file) + or die ("$subr_name - unable to open file $path_to_log_file for readin= g: '$!'"); + gp_message ("debug", $subr_name, "opened file $path_to_log_file for read= ing"); + =20 + while () + { + $line =3D $_; + chomp ($line); + gp_message ("debug", $subr_name, "read line: $line"); +#-------------------------------------------------------------------------= ----- +# Search for the first line starting with " +# +#-------------------------------------------------------------------------= ----- + if ($line =3D~ /^\s*) + { + $line =3D $_; + chomp ($line); + gp_message ("debug", $subr_name, "MAP_XML read line =3D $line"); +## if ($line =3D~ /^$/) + if ($line =3D~ /^$/) + { + gp_message ("debug", $subr_name, "target line =3D $line"); + $vaddr =3D $1; + $foffset =3D $2; + $modes =3D $3; + $name_path =3D $4; + $name =3D get_basename ($name_path); + gp_message ("debug", $subr_name, "extracted vaddr =3D $vaddr= foffset =3D $foffset modes =3D $modes"); + gp_message ("debug", $subr_name, "extracted name_path =3D $name_= path name =3D $name"); +# $error_extracting_information =3D $TRUE; + $executable_name =3D $name; + my $result_VA =3D hex ($vaddr) - hex ($foffset); + my $hex_VA =3D sprintf ("0x%016x", $result_VA); + $va_executable_in_hex =3D $hex_VA; + gp_message ("debug", $subr_name, "set executable_name =3D $exec= utable_name"); + gp_message ("debug", $subr_name, "set va_executable_in_hex =3D $= va_executable_in_hex"); + gp_message ("debug", $subr_name, "result_VA =3D $result_VA");=20 + gp_message ("debug", $subr_name, "hex_VA =3D $hex_VA");=20 + if ($modes eq "005") + { + $extracted_information =3D $TRUE; + last; + } + } + } + if (not $extracted_information) + { + my $msg =3D "cannot find the necessary information in the $path_to_m= ap_file file"; + gp_message ("assertion", $subr_name, $msg); + } + +## $executable_name =3D $ARCHIVES_MAP_NAME; +## $va_executable_in_hex =3D $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 =3D get_my_name (); + + my ($metric_values, $max_metric_values_ref) =3D @_; + + my @max_metric_values =3D @{ $max_metric_values_ref }; + + my @current_metrics =3D (); + my $colour_coded_line; + my $current_value; + my $hp_value =3D $g_user_settings{"highlight_percentage"}{"current_value= "}; + my $max_value; + my $relative_distance; + + @current_metrics =3D split (" ", $metric_values); + $colour_coded_line =3D $FALSE; + for my $metric (0 .. $#current_metrics) + { + $current_value =3D $current_metrics[$metric]; + if (exists ($max_metric_values[$metric])) + { + $max_value =3D $max_metric_values[$metric]; + gp_message ("debugXL", $subr_name, "metric =3D $metric current_v= alue =3D $current_value max_value =3D $max_value"); + if ( ($max_value > 0) and ($current_value > 0) and ($current_val= ue !=3D $max_value) ) + { +# TBD: abs needed? + gp_message ("debugXL", $subr_name, "metric =3D $metric curre= nt_value =3D $current_value max_value =3D $max_value"); + $relative_distance =3D 1.00 - abs ( ($max_value - $current_v= alue)/$max_value ); + gp_message ("debugXL", $subr_name, "relative_distance =3D $r= elative_distance"); + if ($relative_distance >=3D $hp_value/100.0) + { + gp_message ("debugXL", $subr_name, "metric $metric is wi= thin the relative_distance"); + $colour_coded_line =3D $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 =3D get_my_name (); + + my ($machine_ref) =3D @_; + + my $machine =3D ${ $machine_ref }; + my $is_supported; + + if ($machine eq "x86_64") + { + $is_supported =3D $TRUE; + } + else + { + $is_supported =3D $FALSE; + } + + return (\$is_supported); + +} #-- End of subroutine check_support_for_processor + +#-------------------------------------------------------------------------= ----- +# Check if the value for the user option given is valid. +# +# In case the value is valid, the g_user_settings table is updated. +# Otherwise an error message is printed. +# +# The return value is TRUE/FALSE. +#-------------------------------------------------------------------------= ----- +sub check_user_option +{ + my $subr_name =3D get_my_name (); + + my ($internal_option_name, $value) =3D @_; + + my $message; + my $return_value; + + my $option =3D $g_user_settings{$internal_option_name}{"option"= }; + my $data_type =3D $g_user_settings{$internal_option_name}{"data_ty= pe"}; + my $no_of_arguments =3D $g_user_settings{$internal_option_name}{"no_of_a= rguments"}; + + if (($no_of_arguments >=3D 1) and=20 + ((not defined ($value)) or (length ($value) =3D=3D 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. Sho= uld +# these be introduced, the current check may need to be refined. +#-------------------------------------------------------------------------= ----- + + $message =3D "the $option option requires a value"; + push (@g_user_input_errors, $message); + $return_value =3D $FALSE; + } + elsif ($no_of_arguments >=3D 1) + { +#-------------------------------------------------------------------------= ----- +# There is an input value. Check if it is valid and if so, store it. +# +# Note that we allow the options to be case insensitive. +#-------------------------------------------------------------------------= ----- + my $valid =3D verify_if_input_is_valid ($value, $data_type); + + if ($valid) + { + if (($data_type eq "onoff") or ($data_type eq "size")) + { + $g_user_settings{$internal_option_name}{"current_value"} =3D= lc ($value); + } + else + { + $g_user_settings{$internal_option_name}{"current_value"} =3D= $value; + } + $g_user_settings{$internal_option_name}{"defined"} =3D $TR= UE; + $return_value =3D $TRUE; + } + else + { + $message =3D "incorrect value for $option option: $value"; + push (@g_user_input_errors, $message); + + $return_value =3D $FALSE; + } + } + + return ($return_value); + +} #-- End of subroutine check_user_option + +#-------------------------------------------------------------------------= ------ +# This subroutine performs multiple checks on the experiment directories. = One=20 +# or more failures are fatal. +#-------------------------------------------------------------------------= ------ +sub check_validity_exp_dirs +{ + my $subr_name =3D get_my_name (); + + my ($exp_dir_list_ref) =3D @_; + + my @exp_dir_list =3D @{ $exp_dir_list_ref }; +=20 + my %elf_rats =3D (); + + my $dir_not_found =3D $FALSE; + my $invalid_dir =3D $FALSE; + my $dir_check_errors =3D $FALSE; + my $missing_dirs =3D 0; + my $invalid_dirs =3D 0; + =20 + my $archive_dir_not_empty; + my $elf_magic_number;=20 + my $archives_file; + my $archives_dir;=20 + my $first_line; + my $count_exp_dir_not_elf; +=20 + my $first_time; + my $filename; + + my $comment; + + my $selected_archive_has_elf_format;=20 + + my $selected_archive; + my $archive_dir_selected; + my $no_of_files_in_selected_archive; + +#-------------------------------------------------------------------------= ------ +# Check if the experiment directories exist and are valid. +#-------------------------------------------------------------------------= ------ + for my $exp_dir (@exp_dir_list) + { + if (not -d $exp_dir) + { + $dir_not_found =3D $TRUE; + $missing_dirs++; + gp_message ("error", $subr_name, "directory $exp_dir not found"); + $dir_check_errors =3D $TRUE; + } + else + { +#-------------------------------------------------------------------------= ------ +# Files log.xml and map.xml have to be there. +#-------------------------------------------------------------------------= ------ + gp_message ("debug", $subr_name, "directory $exp_dir found"); + if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) + { + gp_message ("debug", $subr_name, "directory $exp_dir appears= to be a valid experiment directory"); + } + else + { + $invalid_dir =3D $TRUE; + $invalid_dirs++;=20 + gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml = and/or ".$exp_dir."/map.xml missing"); + gp_message ("error" , $subr_name, "directory $exp_dir does = not appear to be a valid experiment directory"); + $dir_check_errors =3D $TRUE; + } + } + } + if ($dir_not_found) + { + gp_message ("error", $subr_name, "a total of $missing_dirs directori= es not found"); + } + if ($invalid_dir) + { + gp_message ("abort", $subr_name, "a total of $invalid_dirs directori= es are not valid"); + } + +#-------------------------------------------------------------------------= ------ +# Initialize ELF status to FALSE. +#-------------------------------------------------------------------------= ------ +## for my $exp_dir (@exp_dir_list) + for my $exp_dir (keys %g_exp_dir_meta_data) + { + $g_exp_dir_meta_data{$exp_dir}{"elf_format"} =3D $FALSE;=20 + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} =3D $FALSE; = + } +#-------------------------------------------------------------------------= ------ +# Check if the load objects are in ELF format. +#-------------------------------------------------------------------------= ------ + for my $exp_dir (keys %g_exp_dir_meta_data) + { + $archives_dir =3D $g_exp_dir_meta_data{$exp_dir}{"directory_path"} .= $exp_dir . "/archives"; + $archive_dir_not_empty =3D $FALSE; + $first_time =3D $TRUE; + $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} =3D $TRUE; + $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} =3D 0; + + gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'arc= hive_is_empty'} =3D $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); + gp_message ("debug", $subr_name, "checking $archives_dir"); + + while (glob ("$archives_dir/*")) + { + $filename =3D get_basename ($_); + gp_message ("debug", $subr_name, "processing file: $filename"); + + $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} =3D $= TRUE; + $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; + + $archive_dir_not_empty =3D $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 =3D rindex ($filename,"."); + my $underscore_before_dot =3D $TRUE; + my $first_underscore =3D -1; + gp_message ("debugXL", $subr_name, "last_dot =3D $last_dot"); + while ($underscore_before_dot) + { + $first_underscore =3D index ($filename, "_", $first_undersco= re+1); + if ($last_dot < $first_underscore) + { + $underscore_before_dot =3D $FALSE; + } + } + my $original_name =3D substr ($filename, 0, $first_underscore); + gp_message ("debug", $subr_name, "stripped archive name: $origin= al_name"); + if (not exists ($elf_rats{$original_name})) + { + $elf_rats{$original_name} =3D [$filename, $exp_dir]; + } +#-------------------------------------------------------------------------= ------ +# We only need to detect the presence of an object once. +#-------------------------------------------------------------------------= ------ + if ($first_time) + { + $first_time =3D $FALSE; + $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} =3D $FALS= E; + gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp= _dir}{'archive_is_empty'} =3D $g_exp_dir_meta_data{$exp_dir}{'archive_is_em= pty'}"); + } + } + } #-- End of loop over experiment directories + + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + my $empty =3D $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};=20 + gp_message ("debug", $subr_name, "archive directory $exp_dir/archive= s is ".($empty ? "empty" : "not empty")); + } + +#-------------------------------------------------------------------------= ----- +# Verify that all relevant files in the archive directories are in ELF for= mat. +#-------------------------------------------------------------------------= ----- + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} =3D $FALSE; = + if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) + { + $archives_dir =3D $g_exp_dir_meta_data{$exp_dir}{"directory_path= "} . $exp_dir . "/archives"; + gp_message ("debug", $subr_name, "exp_dir =3D $exp_dir archives_= dir =3D $archives_dir"); +#-------------------------------------------------------------------------= ----- +# Check if any of the loadobjects is of type ELF. Bail out on the first o= ne +# 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}{"archi= ve_files"}}) + { + $filename =3D $g_exp_dir_meta_data{$exp_dir}{"directory_path= "} . $exp_dir . "/archives/" . $aname; + open (ARCF,"<", $filename) + or die ("unable to open file $filename for reading - '$!'"= ); + + $first_line =3D ; + close (ARCF); + +#-------------------------------------------------------------------------= ----- +# The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7F= ELF). +# +# See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format +#-------------------------------------------------------------------------= ----- +# if ($first_line =3D~ /^\177ELF.*/) + + $elf_magic_number =3D unpack ('H8', $first_line); +# gp_message ("debug", $subr_name, "elf_magic_number =3D $elf= _magic_number"); + if ($elf_magic_number eq "7f454c46") + { + $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = =3D $TRUE;=20 + $g_exp_dir_meta_data{$exp_dir}{"elf_format"} =3D $TRUE; + last; + } + } + } + } + + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + $comment =3D "the loadobjects in the archive in $exp_dir are "; + $comment .=3D ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format= "}) ? "in " : "not in "; + $comment .=3D "ELF format"; + gp_message ("debug", $subr_name, $comment); + } + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) + { + gp_message ("debug", $subr_name, "there are no archived files in= $exp_dir"); + } + } + +#-------------------------------------------------------------------------= ----- +# If there are archived files and they are not in ELF format, a debug is +# issued. +# +# TBD: Bail out? +#-------------------------------------------------------------------------= ----- + $count_exp_dir_not_elf =3D 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++;=20 + } + } + if ($count_exp_dir_not_elf !=3D 0) + { + gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf e= xperiments with non-ELF load objects"); + } + +#-------------------------------------------------------------------------= ----- +# Select the experiment directory that is used for the files in the archiv= e. +# By default, a directory with archived files is used, but in case this do= es +# not exist, a directory without archived files is selected. Obviously th= is +# needs to be dealt with later on. +#-------------------------------------------------------------------------= ----- + +#-------------------------------------------------------------------------= ----- +# Try the experiments with archived files first. +#-------------------------------------------------------------------------= ----- + $archive_dir_not_empty =3D $FALSE; + $archive_dir_selected =3D $FALSE; +## for my $exp_dir (sort @exp_dir_list) + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + gp_message ("debugXL", $subr_name, "exp_dir =3D $exp_dir"); + gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'a= rchive_is_empty'}"); + + if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) + { + $selected_archive =3D $exp_dir; + $archive_dir_not_empty =3D $TRUE; + $archive_dir_selected =3D $TRUE; + $selected_archive_has_elf_format =3D ($g_exp_dir_meta_data{$exp_= dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE; + last; + } + } + if (not $archive_dir_selected)=20 +#-------------------------------------------------------------------------= ----- +# 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 =3D $exp_dir; + $archive_dir_not_empty =3D $FALSE; + $archive_dir_selected =3D $TRUE; + $selected_archive_has_elf_format =3D $FALSE; + last; + } + } + } + gp_message ("debug", $subr_name, "experiment $selected_archive has been = selected for archive analysis"); + gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_= empty) ? "not empty" : "empty")); + gp_message ("debug", $subr_name, "this archive is ". (($selected_archive= _has_elf_format) ? "in" : "not in")." ELF format"); +#-------------------------------------------------------------------------= ----- +# Get the size of the hash that contains the archived files. +#-------------------------------------------------------------------------= ----- +## $NO_OF_FILES_IN_ARCHIVE =3D scalar (keys %ARCHIVES_FILES); + + $no_of_files_in_selected_archive =3D $g_exp_dir_meta_data{$selected_arch= ive}{"no_of_files_in_archive"}; + gp_message ("debug", $subr_name, "number of files in archive $selected_a= rchive is $no_of_files_in_selected_archive"); + + + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + my $is_empty =3D $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; + gp_message ("debug", $subr_name, "archive directory $exp_dir/archive= s is ".($is_empty ? "empty" : "not empty")); + } + for my $exp_dir (sort keys %g_exp_dir_meta_data) + { + if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) + { + for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"arch= ive_files"}}) + { + gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_di= r_meta_data{$exp_dir}[...] [diff truncated at 100000 bytes]